diff options
Diffstat (limited to 'tests')
176 files changed, 26404 insertions, 6373 deletions
diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index d4d2a7c..fffc1cc 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.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) 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. diff --git a/tests/all.tcl b/tests/all.tcl index 5ac2abb..8cd0cf4 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,16 +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 require Tcl 8.5- +package prefer latest package require tcltest 2.5 namespace import ::tcltest::* diff --git a/tests/append.test b/tests/append.test index 0b06c8f..1055ae0 100644 --- a/tests/append.test +++ b/tests/append.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-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. @@ -15,8 +15,12 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands unset -nocomplain x +catch [list package require -exact tcl::test [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + test append-1.1 {append command} { unset -nocomplain x list [append x 1 2 abc "long string"] $x @@ -53,6 +57,35 @@ 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.6 {append surrogates} -body { + set x \uDE02 + set x \uD83D$x +} -result \uD83D\uDE02 +test append-3.7 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \xC0] + string length [append x [testbytestring \x80]] +} -result 2 +test append-3.8 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \xC0] + string length $x[testbytestring \x80] +} -result 2 +test append-3.9 {append \xC0 \x80} -constraints testbytestring -body { + set x [testbytestring \x80] + string length [testbytestring \xC0]$x +} -result 2 +test append-3.10 {append surrogates} -body { + set x \uD83D + string range $x 0 end + append x \uDE02 +} -result [string range \uD83D\uDE02 0 end] test append-4.1 {lappend command} { unset -nocomplain x @@ -188,7 +221,7 @@ test append-7.1 {lappend-created var and error in trace on that var} -setup { catch {rename foo ""} unset -nocomplain x } -body { - trace variable x w foo + trace add variable x write foo proc foo {} {global x; unset x} catch {lappend x 1} proc foo {args} {global x; unset x} @@ -201,37 +234,37 @@ test append-7.2 {lappend var triggers read trace} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar a return $::result -} -result {myvar {} r} +} -result {myvar {} read} test append-7.3 {lappend var triggers read trace, array var} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them, and was changed back in 8.4. - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result -} -result {myvar b r} +} -result {myvar b read} test append-7.4 {lappend var triggers read trace, array var exists} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { set myvar(0) 1 - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result -} -result {myvar b r} +} -result {myvar b read} test append-7.5 {append var does not trigger read trace} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} append myvar a info exists ::result diff --git a/tests/appendComp.test b/tests/appendComp.test index 0b2beb9..ddb4fb2 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.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-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. @@ -250,7 +250,7 @@ test appendComp-7.1 {lappendComp-created var and error in trace on that var} -se } -body { proc bar {} { global x - trace variable x w foo + trace add variable x write foo proc foo {} {global x; unset x} catch {lappend x 1} proc foo {args} {global x; unset x} @@ -265,19 +265,19 @@ test appendComp-7.2 {lappend var triggers read trace, index var} -setup { unset -nocomplain ::result } -body { proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar a return $::result } bar -} -result {myvar {} r} -constraints {bug-3057639} +} -result {myvar {} read} -constraints {bug-3057639} test appendComp-7.3 {lappend var triggers read trace, stack var} -setup { unset -nocomplain ::result unset -nocomplain ::myvar } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar a return $::result @@ -290,67 +290,67 @@ test appendComp-7.4 {lappend var triggers read trace, array var} -setup { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result } bar -} -result {myvar b r} -constraints {bug-3057639} +} -result {myvar b read} -constraints {bug-3057639} test appendComp-7.5 {lappend var triggers read trace, array var} -setup { unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a b return $::result } bar -} -result {myvar b r} +} -result {myvar b read} test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { unset -nocomplain ::result } -body { proc bar {} { set myvar(0) 1 - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result } bar -} -result {myvar b r} -constraints {bug-3057639} +} -result {myvar b read} -constraints {bug-3057639} test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { unset -nocomplain ::myvar unset -nocomplain ::result } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar(b) a return $::result } bar -} -result {::myvar b r} -constraints {bug-3057639} +} -result {::myvar b read} -constraints {bug-3057639} test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { unset -nocomplain ::myvar unset -nocomplain ::result } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar(b) a b return $::result } bar -} -result {::myvar b r} +} -result {::myvar b read} test appendComp-7.9 {append var does not trigger read trace} -setup { unset -nocomplain ::result } -body { proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} append myvar a info exists ::result diff --git a/tests/apply.test b/tests/apply.test index 1a3c96d..24b27cc 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -4,10 +4,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-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. @@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints memory -body { +} -constraints {memory} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] diff --git a/tests/assemble.test b/tests/assemble.test index 42c268a..b656894 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. @@ -781,7 +781,7 @@ test assemble-7.43 {uplus} { } } -returnCodes error - -result {can't use non-numeric floating-point value as operand of "+"} + -result {can't use non-numeric floating-point value "NaN" as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { @@ -852,10 +852,11 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { @@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} { } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr diff --git a/tests/assocd.test b/tests/assocd.test index 863bf78..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.5 -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 86527bf..49a00ff 100644 --- a/tests/async.test +++ b/tests/async.test @@ -4,9 +4,9 @@ # 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. @@ -17,11 +17,11 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [::tcl::pkgconfig get threaded] -testConstraint notWinCI [expr {$::tcl_platform(platform) != "windows" || ![info exists ::env(CI)]}] +testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]] proc async1 {result code} { global aresult acode @@ -150,7 +150,7 @@ test async-3.1 {deleting handlers} testasync { } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync threaded + testasync thread } -setup { set hm [testasync create async3] proc nothing {} { @@ -179,7 +179,7 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - testasync threaded + testasync thread } -setup { set hm [testasync create async3] } -body { @@ -204,7 +204,7 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - testasync threaded notWinCI + testasync thread knownMsvcBug } -setup { set hm [testasync create async3] } -body { 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/autoMkindex.test b/tests/autoMkindex.test index 6adb403..214a969 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -3,8 +3,8 @@ # 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. @@ -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::* @@ -164,17 +164,17 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { # 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 { diff --git a/tests/basic.test b/tests/basic.test index bf2b08f..c90d80e 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -9,8 +9,8 @@ # 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. @@ -21,7 +21,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -348,7 +348,7 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken { catch {rename \# ""} set x [testcmdtoken create \#] - testcmdtoken name $x + return [testcmdtoken name $x] } {{#} ::#} test basic-21.1 {Tcl_GetCommandName} {emptyTest} { @@ -672,7 +672,7 @@ proc l3 {} { } # Do all tests once byte compiled and once with direct string evaluation -for {set noComp 0} {$noComp <= 1} {incr noComp} { +foreach noComp {0 1} { if {$noComp} { interp alias {} run {} testevalex @@ -895,21 +895,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { rename stress {} } -result 0 -test basic-48.17.$noComp {expansion: object safety} -setup { - set old_precision $::tcl_precision - set ::tcl_precision 4 - } -constraints $constraints -body { +test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] - set res [list] + set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { - set ::tcl_precision $old_precision - unset old_precision res t l x third + unset res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { diff --git a/tests/binary.test b/tests/binary.test index 15c0b28..2782a9d 100644 --- a/tests/binary.test +++ b/tests/binary.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) 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. @@ -15,10 +15,11 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch {package require -exact Tcltest [info patchlevel]} +catch [list package require -exact tcl::test [info patchlevel]] testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] +testConstraint testbytestring [llength [info commands testbytestring]] # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -27,9 +28,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) @@ -39,19 +40,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) @@ -61,11 +62,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 @@ -162,16 +163,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 @@ -193,16 +194,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 @@ -221,19 +222,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 @@ -255,19 +256,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 @@ -487,34 +488,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\x80\x00\x00 test binary-13.13 {Tcl_BinaryObjCmd: float overflow} littleEndian { binary format f -3.402825e+38 -} \xff\xff\x7f\xff +} \x00\x00\x80\xFF test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian { binary format f -3.402825e-100 } \x80\x00\x00\x00 @@ -531,11 +532,23 @@ 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-13.20 {Tcl_BinaryObjCmd: format float Inf} bigEndian { + binary format f Inf +} \x7F\x80\x00\x00 +test binary-13.21 {Tcl_BinaryObjCmd: format float Inf} littleEndian { + binary format f Inf +} \x00\x00\x80\x7F +test binary-13.22 {Tcl_BinaryObjCmd: format float -Inf} bigEndian { + binary format f -Inf +} \xFF\x80\x00\x00 +test binary-13.23 {Tcl_BinaryObjCmd: format float -Inf} littleEndian { + binary format f -Inf +} \x00\x00\x80\xFF test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format d @@ -548,28 +561,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} @@ -580,11 +593,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 @@ -761,7 +774,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.14 {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} @@ -867,11 +889,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 @@ -883,7 +905,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 @@ -913,11 +935,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 @@ -929,7 +951,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 @@ -958,27 +980,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 @@ -999,15 +1021,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 @@ -1027,23 +1049,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 @@ -1060,23 +1082,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 { @@ -1084,23 +1106,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 @@ -1117,15 +1139,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 { @@ -1133,23 +1155,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 @@ -1166,15 +1188,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 @@ -1186,23 +1208,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 @@ -1219,15 +1241,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 @@ -1239,43 +1261,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 @@ -1286,19 +1308,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 { @@ -1306,43 +1328,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 @@ -1353,19 +1375,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} { @@ -1536,20 +1558,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 @@ -1569,7 +1591,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 @@ -1590,11 +1612,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 { @@ -1620,22 +1642,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 { @@ -1650,22 +1672,6 @@ test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH -test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan HelloTcl W x - set x -} 5216694956358656876 -test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan lcTolleH w x - set x -} 5216694956358656876 -test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format w [expr {wide(3) << 31}]] w x - set x -} 6442450944 -test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format W [expr {wide(3) << 31}]] W x - set x -} 6442450944 test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 @@ -1687,6 +1693,31 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} +test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan HelloTcl W x + set x +} 5216694956358656876 +test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan lcTolleH w x + set x +} 5216694956358656876 +test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format w [expr {wide(3) << 31}]] w x + set x +} 6442450944 +test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format W [expr {wide(3) << 31}]] W x + set x +} 6442450944 +test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x + set x +} 6442450944 +test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x + set x +} 6442450944 + test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} { binary scan [binary format sws 16450 -1 19521] c* x set x @@ -1697,26 +1728,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 @@ -1882,28 +1913,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} @@ -1914,11 +1945,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 { @@ -1932,34 +1963,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\x80\x00\x00 test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} { binary format r -3.402825e+38 -} \xff\xff\x7f\xff +} \x00\x00\x80\xFF test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} { binary format R -3.402825e-100 } \x80\x00\x00\x00 @@ -1976,11 +2007,44 @@ 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 +test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} { + binary format R Inf +} \x7F\x80\x00\x00 +test binary-53.21 {Tcl_BinaryObjCmd: float Inf} {} { + binary format r Inf +} \x00\x00\x80\x7F +test binary-53.22 {Binary float Inf round trip} -body { + binary scan [binary format R Inf] R inf + binary scan [binary format R -Inf] R inf_ + list $inf $inf_ +} -result {Inf -Inf} +test binary-53.23 {Binary float round to FLT_MAX} -body { + binary scan [binary format H* 7f7fffff] R fltmax + binary scan [binary format H* 47effffff0000000] Q round_to_fltmax + binary scan [binary format R $round_to_fltmax] R fltmax1 + expr {$fltmax eq $fltmax1} +} -result 1 +test binary-53.24 {Binary float round to -FLT_MAX} -body { + binary scan [binary format H* ff7fffff] R fltmax + binary scan [binary format H* c7effffff0000000] Q round_to_fltmax + binary scan [binary format R $round_to_fltmax] R fltmax1 + expr {$fltmax eq $fltmax1} +} -result 1 +test binary-53.25 {Binary float round to Inf} -body { + binary scan [binary format H* 47effffff0000001] Q round_to_inf + binary scan [binary format R $round_to_inf] R inf1 + expr {$inf1 eq Inf} +} -result 1 +test binary-53.26 {Binary float round to -Inf} -body { + binary scan [binary format H* c7effffff0000001] Q round_to_inf + binary scan [binary format R $round_to_inf] R inf1 + expr {$inf1 eq -Inf} +} -result 1 # scan t (s) test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1988,23 +2052,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 @@ -2021,7 +2085,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 @@ -2042,23 +2106,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 @@ -2075,7 +2139,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 @@ -2096,23 +2160,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 @@ -2129,7 +2193,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 @@ -2150,23 +2214,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 @@ -2183,7 +2247,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 @@ -2204,43 +2268,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 @@ -2251,19 +2315,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 @@ -2272,43 +2336,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 @@ -2319,19 +2383,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 { @@ -2377,11 +2441,27 @@ test binary-62.4 {infinity} ieeeFloatingPoint { format 0x%016lx $w } 0xfff0000000000000 test binary-62.5 {infinity} ieeeFloatingPoint { - binary scan [binary format w 0x7ff0000000000000] q d + binary scan [binary format w 0x7FF0000000000000] q d set d } Inf test binary-62.6 {infinity} ieeeFloatingPoint { - binary scan [binary format w 0xfff0000000000000] q d + binary scan [binary format w 0xFFF0000000000000] q d + set d +} -Inf +test binary-62.7 {infinity} ieeeFloatingPoint { + binary scan [binary format r Inf] iu i + format 0x%08x $i +} 0x7f800000 +test binary-62.8 {infinity} ieeeFloatingPoint { + binary scan [binary format r -Inf] iu i + format 0x%08x $i +} 0xff800000 +test binary-62.9 {infinity} ieeeFloatingPoint { + binary scan [binary format i 0x7F800000] r d + set d +} Inf +test binary-62.10 {infinity} ieeeFloatingPoint { + binary scan [binary format i 0xFF800000] r d set d } -Inf @@ -2389,19 +2469,19 @@ test binary-62.6 {infinity} ieeeFloatingPoint { test binary-63.1 {NaN} ieeeFloatingPoint { binary scan [binary format q NaN] w w - format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] + format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}] } 0x7ff0000000000000 test binary-63.2 {NaN} ieeeFloatingPoint { binary scan [binary format q -NaN] w w - format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] + format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}] } 0xfff0000000000000 test binary-63.3 {NaN} ieeeFloatingPoint { binary scan [binary format q NaN(3123456789aBc)] w w - format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] + format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}] } 0x7ff3123456789abc test binary-63.4 {NaN} ieeeFloatingPoint { binary scan [binary format q {NaN( 3123456789aBc)}] w w - format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] + format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}] } 0x7ff3123456789abc # Make sure TclParseNumber() rejects invalid nan-hex formats [Bug 3402540] @@ -2480,7 +2560,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 { @@ -2497,16 +2577,16 @@ 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} test binary-71.7 {binary decode hex} -body { binary decode hex "61\n\n\n61" } -result {aa} -test binary-71.8 {binary decode hex} -body { +test binary-71.8 {binary decode hex} -match glob -body { binary decode hex -strict "61 61" -} -returnCodes error -result {invalid hexadecimal digit " " at position 2} +} -returnCodes error -result {invalid hexadecimal digit " " * at position 2} test binary-71.9 {binary decode hex} -body { set r [binary decode hex "6"] list [string length $r] $r @@ -2556,19 +2636,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 @@ -2628,7 +2708,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 { @@ -2645,19 +2725,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 @@ -2668,11 +2748,11 @@ test binary-73.11 {binary decode base64} -body { } -result [string repeat abc 20] test binary-73.12 {binary decode base64} -body { binary decode base64 -strict ":YWJj" -} -returnCodes error -match glob -result {invalid base64 character ":" at position 0} +} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0} test binary-73.13 {binary decode base64} -body { set s "[string repeat YWJj 10]:[string repeat YWJj 10]" binary decode base64 -strict $s -} -returnCodes error -match glob -result {invalid base64 character ":" at position 40} +} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40} test binary-73.14 {binary decode base64} -body { set s "[string repeat YWJj 10]\n [string repeat YWJj 10]" binary decode base64 -strict $s @@ -2775,22 +2855,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 { @@ -2826,7 +2906,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 @@ -2849,11 +2929,11 @@ test binary-75.11 {binary decode uuencode} -body { } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} +} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0} test binary-75.13 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} +} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41} test binary-75.14 {binary decode uuencode} -body { set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s @@ -2881,7 +2961,7 @@ test binary-75.24 {binary decode uuencode} -body { test binary-75.25 {binary decode uuencode} -body { set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} +} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 @@ -2905,6 +2985,26 @@ test binary-76.2 {binary string appending growth algorithm} win { string length [append str [binary format a* foo]] } 3 +test binary-77.1 {string cat ops on all bytearrays} { + apply {{a b} { + return [binary format H* $a][binary format H* $b] + }} ab cd +} [binary format H* abcd] +test binary-77.2 {string cat ops on all bytearrays} { + apply {{a b} { + set one [binary format H* $a] + return $one[binary format H* $b] + }} ab cd +} [binary format H* abcd] + +test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body { + # just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3): + binary encode hex \U0001f415 + binary scan \U0001f415 a* v; set v + set str {} +} -result {} + + testConstraint testsetbytearraylength \ [expr {"testsetbytearraylength" in [info commands]}] @@ -2912,10 +3012,22 @@ 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 "乎" +} -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 '乎' (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 '乎' (U+004E4E)" +test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { + testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] +} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/case.test b/tests/case.test index d32d7d3..1c12e3a 100644 --- a/tests/case.test +++ b/tests/case.test @@ -4,13 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +if {![llength [info commands case]]} { + # No "case" command? So no need to test + return +} + if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/chan.test b/tests/chan.test index 5d05935..4155c36 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -2,7 +2,7 @@ # 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. @@ -48,20 +48,20 @@ 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 {}] -} -returnCodes ok -result {} +} -result {} test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { chan configure stdout -eofchar [list \x27 \x80] } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} +} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index aef6a1b..f3461f0 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6,19 +6,24 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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.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 @@ -31,8 +36,8 @@ 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] } source [file join [file dirname [info script]] tcltests.tcl] @@ -47,6 +52,7 @@ namespace eval ::tcl::test::io { testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # File permissions broken on wsl without some "exotic" wsl configuration testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}] + testConstraint specialfiles [expr {[file exists /dev/zero] || [file exists NUL]}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... @@ -76,7 +82,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 \x1A" chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -112,14 +118,14 @@ 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\x00 + chan puts -nonewline $f "a\x4D\x00" chan close $f contents $path(test1) } 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" @@ -248,7 +254,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod test chan-io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -261,7 +267,7 @@ test chan-io-3.5 {WriteChars: saved != 0} -body { # be moved to beginning of next channel buffer to preserve requested # buffersize. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -274,13 +280,13 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body { # 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)] @@ -294,7 +300,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # on flush. The truncated bytes are moved to the beginning of the next # channel buffer. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -428,7 +434,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\x00" + chan puts $f "\x81\x34\x00" chan close $f set f [open $path(test1)] chan configure $f -translation binary @@ -446,7 +452,7 @@ test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body { 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 @@ -477,17 +483,17 @@ test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1A + chan configure $f -eofchar "\x1A \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 \x1A" list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -902,7 +908,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none - chan configure $f -encoding unicode + chan configure $f -encoding utf-16 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f @@ -995,7 +1001,7 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b 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 \x1A" list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -1023,14 +1029,14 @@ 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 {} @@ -1064,14 +1070,14 @@ 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] @@ -1092,13 +1098,13 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] - chan configure $f -encoding shiftjis + chan configure $f -encoding shiftjis -profile tcl8 lappend x [chan gets $f line] $line lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] lappend x [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 16 "1234567890123\uFF10\uFF11\x82" 18 0 1 -1 ""] +} -result [list 16 "1234567890123０１\x82" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" } -constraints {stdio fileevent} -body { @@ -1117,7 +1123,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) @@ -1143,7 +1149,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { chan event $f read [namespace code { lappend x [chan gets $f line] $line [testchannel inputbuffered $f] }] - chan configure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here @@ -1375,7 +1381,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { 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 fileevent} -body { @@ -1408,7 +1414,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] @@ -3101,7 +3107,7 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan read $f } -cleanup { chan close $f @@ -3114,11 +3120,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 -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan read $f } -cleanup { chan close $f @@ -3136,7 +3142,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3157,7 +3163,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3235,7 +3241,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3249,7 +3255,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3263,7 +3269,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3277,7 +3283,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3291,7 +3297,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3305,7 +3311,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 \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3656,7 +3662,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3672,11 +3678,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 -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3696,7 +3702,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3714,7 +3720,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3798,7 +3804,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3816,7 +3822,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3834,7 +3840,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3852,7 +3858,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3870,7 +3876,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3888,7 +3894,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 \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -4644,12 +4650,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4658,12 +4664,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4672,12 +4678,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4686,12 +4692,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4700,12 +4706,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4714,12 +4720,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 \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 \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4733,7 +4739,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4747,7 +4753,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4761,7 +4767,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4775,7 +4781,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4789,7 +4795,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4803,7 +4809,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 \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4976,7 +4982,7 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup { test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - chan configure $chan -buffersize 10 + chan configure $chan -buffersize 10 -encoding utf-8 set var [chan read $chan 2] chan configure $chan -buffersize 32 append var [chan read $chan] @@ -5180,7 +5186,7 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { 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 { @@ -5193,7 +5199,7 @@ test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { 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] @@ -5286,7 +5292,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar D + chan configure $f1 -eofchar {D D} lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 @@ -5298,7 +5304,7 @@ test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { set f1 [open $path(test1) w+] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar D + chan configure $f1 -eofchar {D D} lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { @@ -5518,6 +5524,60 @@ test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event gorp who-knows } -returnCodes error -result {bad event name "who-knows": must be readable or writable} + +test chan-io-41.6 {Tcl_FileeventCmd: directory} -constraints {fileevent unix} -setup { + set tempdir [::tcltests::tempdir] +} -body { + set chan [open $tempdir] + chan event $chan readable [list ::apply [list {} { + variable success + set success 1 + } [namespace current]]] + vwait [namespace current]::success + return $success +} -cleanup { + close $chan + file delete -force tempdir +} -result 1 + + +test chan-io-41.7 {Tcl_FileeventCmd: special} -constraints { + fileevent specialfiles +} -body { + set special /dev/zero + if {![file exists $special]} { + set special NUL + } + set chan [open $special] + chan event $chan readable [list ::apply [list {} { + variable success + set success 1 + } [namespace current]]] + vwait [namespace current]::success + return $success +} -cleanup { + close $chan +} -result 1 + + +test chan-io-41.8 {Tcl_FileeventCmd: symbolic link} -constraints {fileevent unix} -setup { + set tempdir [::tcltests::tempdir] +} -body { + set target [makeFile {not again} thefile $tempdir] + set link [file join $tempdir thelin] + file link -symbolic $link $target + set chan [open $link] + chan event $chan readable [list ::apply [list {} { + variable success + set success 1 + } [namespace current]]] + vwait [namespace current]::success + return $success +} -cleanup { + close $chan + file delete -force $tempdir +} -result 1 + # # Test chan event on a file # @@ -5991,7 +6051,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6015,7 +6075,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6039,7 +6099,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6063,7 +6123,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6087,7 +6147,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6111,7 +6171,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 -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6135,7 +6195,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 -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6159,7 +6219,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6183,7 +6243,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 -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6207,7 +6267,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6231,7 +6291,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 -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6255,7 +6315,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 \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6792,7 +6852,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. @@ -6815,7 +6875,7 @@ test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { +test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { # encoding to binary (=> implies that the internal utf-8 is written) set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] @@ -6823,14 +6883,16 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { # -translation binary is also -encoding binary chan configure $out -translation binary chan copy $in $out + file size $path(utf8-fcopy.txt) +} -cleanup { chan close $in chan close $out - file size $path(utf8-fcopy.txt) -} 5 + unset in out +} -result 5 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 @@ -7528,7 +7590,7 @@ test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # cut of the remainder of the error stack, especially the filename set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] list $x $result -} {1 {gets {} catch {error writing "stdout": invalid argument}}} +} {1 {gets {} catch {error writing "stdout": invalid or incomplete multibyte or wide character}}} test chan-io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] diff --git a/tests/clock.test b/tests/clock.test index 587828f..4bac104 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -6,7 +6,7 @@ # 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. @@ -32,10 +32,6 @@ testConstraint detroit \ testConstraint y2038 \ [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}] -if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { - namespace import ::tcl::unsupported::timerate -} - # TEST PLAN # clock-1: @@ -238,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]] } @@ -35474,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 @@ -35490,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 @@ -36801,16 +36797,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 \ @@ -36942,10 +36938,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} diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 526c261..7cae5c8 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -4,23 +4,24 @@ # 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 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint time64bit [expr { $::tcl_platform(pointerSize) >= 8 || [llength [info command testsize]] && [testsize st_mtime] >= 8 @@ -30,6 +31,8 @@ testConstraint linkDirectory [expr { ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] +# File permissions broken on wsl without some "exotic" wsl configuration testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}] global env @@ -170,77 +173,502 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} -test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { +### +# encoding command + +set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl::encoding::)system \?encoding\?"$} +set "numargErrors(encoding convertfrom)" {wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertfrom data"} +set "numargErrors(encoding convertto)" {wrong # args: should be "(encoding |::tcl::encoding::)convertto \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertto data"} +set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} +set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} + +source [file join [file dirname [info script]] encodingVectors.tcl] + + +# Maps utf-{16,32}{le,be} to utf-16, utf-32 and +# others to "". Used to test utf-16, utf-32 based +# on system endianness +proc endianUtf {enc} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set endian le + } else { + set endian be + } + if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} { + return [string range $enc 0 5] + } + return "" +} + +# +# Check errors for invalid number of arguments +proc badnumargs {id cmd cmdargs} { + variable numargErrors + test $id.a "Syntax error: $cmd $cmdargs" \ + -body [list {*}$cmd {*}$cmdargs] \ + -result $numargErrors($cmd) \ + -match regexp \ + -returnCodes error + test $id.b "Syntax error: $cmd (byte compiled)" \ + -setup [list proc compiled_proc {} [list {*}$cmd {*}$cmdargs]] \ + -body {compiled_proc} \ + -cleanup {rename compiled_proc {}} \ + -result $numargErrors($cmd) \ + -match regexp \ + -returnCodes error +} + +# Wraps tests resulting in unknown encoding errors +proc unknownencodingtest {id cmd} { + set result "unknown encoding \"[lindex $cmd end-1]\"" + test $id.a "Unknown encoding error: $cmd" \ + -body [list encoding {*}$cmd] \ + -result $result \ + -returnCodes error + test $id.b "Syntax error: $cmd (byte compiled)" \ + -setup [list proc encoding_test {} [list encoding {*}$cmd]] \ + -body {encoding_test} \ + -cleanup {rename encoding_test {}} \ + -result $result \ + -returnCodes error +} + +# Wraps tests for conversion, successful or not. +# Really more general than just for encoding conversion. +proc testconvert {id body result args} { + test $id.a $body \ + -body $body \ + -result $result \ + {*}$args + dict append args -setup \n[list proc compiled_script {} $body] + dict append args -cleanup "\nrename compiled_script {}" + test $id.b "$body (byte compiled)" \ + -body {compiled_script} \ + -result $result \ + {*}$args +} + +# Wrapper to verify encoding convert{to,from} ?-profile? +# Generates tests for compiled and uncompiled implementation. +# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be} +# The enc and profile are appended to id to generate the test id +proc testprofile {id converter enc profile data result args} { + testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.$profile [list encoding $converter -profile $profile $enc2 $data] $result {*}$args + } + + # If this is the default profile, generate a test without specifying profile + if {$profile eq $::encDefaultProfile} { + testconvert $id.$enc.default [list encoding $converter $enc $data] $result {*}$args + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.default [list encoding $converter $enc2 $data] $result {*}$args + } + } +} + + +# Wrapper to verify encoding convert{to,from} -failindex ?-profile? +# Generates tests for compiled and uncompiled implementation. +# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be} +# The enc and profile are appended to id to generate the test id +proc testfailindex {id converter enc data result failidx {profile default}} { + testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc [list $data]\] \[set idx\]" [list $result $failidx] + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx] + } + + # If this is the default profile, generate a test without specifying profile + if {$profile eq $::encDefaultProfile} { + testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc [list $data]\] \[set idx]" [list $result $failidx] + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx] + } + } +} + +test cmdAH-4.1.1 {encoding} -returnCodes error -body { encoding } -result {wrong # args: should be "encoding subcommand ?arg ...?"} -test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { +test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} -test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data"} -test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertto foo bar -} -result {unknown encoding "foo"} -test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, or system} + +# +# encoding system 4.2.* +badnumargs cmdAH-4.2.1 {encoding system} {ascii ascii} +test cmdAH-4.2.2 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system jis0208 - encoding convertto \u4e4e + encoding system iso8859-1 + encoding system } -cleanup { encoding system $system -} -result 8C -test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { +} -result iso8859-1 + +# +# encoding convertfrom 4.3.* + +# Odd number of args is always invalid since last two args +# are ENCODING DATA and all options take a value +badnumargs cmdAH-4.3.1 {encoding convertfrom} {} +badnumargs cmdAH-4.3.2 {encoding convertfrom} {-failindex VAR ABC} +badnumargs cmdAH-4.3.3 {encoding convertfrom} {-profile VAR ABC} +badnumargs cmdAH-4.3.4 {encoding convertfrom} {-failindex VAR -profile strict ABC} +badnumargs cmdAH-4.3.5 {encoding convertfrom} {-profile strict -failindex VAR ABC} + +# Test that last two args always treated as ENCODING DATA +unknownencodingtest cmdAH-4.3.6 {convertfrom -failindex ABC} +unknownencodingtest cmdAH-4.3.7 {convertfrom -profile ABC} +unknownencodingtest cmdAH-4.3.8 {convertfrom nosuchencoding ABC} +unknownencodingtest cmdAH-4.3.9 {convertfrom -failindex VAR -profile ABC} +unknownencodingtest cmdAH-4.3.10 {convertfrom -profile strict -failindex ABC} +testconvert cmdAH-4.3.11 { + encoding convertfrom jis0208 \x38\x43 +} 乎 -setup { set system [encoding system] -} -body { encoding system iso8859-1 - encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system -} -result 8C -test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} -test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertfrom foo bar -} -result {unknown encoding "foo"} -test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { +} + +# Verify single arg defaults to system encoding +testconvert cmdAH-4.3.12 { + encoding convertfrom \x38\x43 +} 乎 -setup { set system [encoding system] -} -body { encoding system jis0208 - encoding convertfrom 8C } -cleanup { encoding system $system -} -result \u4e4e -test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { +} + +# convertfrom ?-profile? : valid byte sequences +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes $str + testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes $str$suffix + testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes $prefix$str + testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix + } +} + +# convertfrom ?-profile? : invalid byte sequences +foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + if {"knownBug" in $ctrl} continue + set bytes [binary format H* $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] + set result [list $str] + # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch + # so glob it out in error message pattern for now. + set errorWithoutPrefix [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob] + set errorWithPrefix [list "unexpected byte sequence starting at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob] + if {$ctrl eq {} || "solo" in $ctrl} { + if {$failidx == -1} { + set result [list $str] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes {*}$result + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + set result [list $str$suffix] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes {*}$result + } + if {$ctrl eq {} || "tail" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix$str] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes {*}$result + } + if {$ctrl eq {} || "middle" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix$str$suffix] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes {*}$result + } +} + +# convertfrom -failindex ?-profile? - valid data +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + foreach profile $encProfiles { + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str -1 $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $str$suffix -1 $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $prefix$str -1 $profile + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix -1 $profile + } +} + +# convertfrom -failindex ?-profile? - invalid data +foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + if {"knownBug" in $ctrl} continue + # There are multiple test cases based on location of invalid bytes + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] + if {$ctrl eq {} || "solo" in $ctrl} { + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str $failidx $profile + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + # If success expected + set result $str$suffix + } else { + # Failure expected + set result "" + } + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $result $failidx $profile + } + if {$ctrl eq {} || "tail" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$str + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $result $expected_failidx $profile + } + if {$ctrl eq {} || "middle" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$str$suffix + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $result $expected_failidx $profile + } +} + +# +# encoding convertto 4.4.* + +badnumargs cmdAH-4.4.1 {encoding convertto} {} +badnumargs cmdAH-4.4.2 {encoding convertto} {-failindex VAR ABC} +badnumargs cmdAH-4.4.3 {encoding convertto} {-profile VAR ABC} +badnumargs cmdAH-4.4.4 {encoding convertto} {-failindex VAR -profile strict ABC} +badnumargs cmdAH-4.4.5 {encoding convertto} {-profile strict -failindex VAR ABC} + +# Test that last two args always treated as ENCODING DATA +unknownencodingtest cmdAH-4.4.6 {convertto -failindex ABC} +unknownencodingtest cmdAH-4.4.7 {convertto -profile ABC} +unknownencodingtest cmdAH-4.4.8 {convertto nosuchencoding ABC} +unknownencodingtest cmdAH-4.4.9 {convertto -failindex VAR -profile ABC} +unknownencodingtest cmdAH-4.4.10 {convertto -profile strict -failindex ABC} +testconvert cmdAH-4.4.11 { + encoding convertto jis0208 乎 +} \x38\x43 -setup { set system [encoding system] -} -body { encoding system iso8859-1 - encoding convertfrom jis0208 8C } -cleanup { encoding system $system -} -result \u4e4e -test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding names foo -} -result {wrong # args: should be "encoding names"} -test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding system foo bar -} -result {wrong # args: should be "encoding system ?encoding?"} -test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { +} + +# Verify single arg defaults to system encoding +testconvert cmdAH-4.4.12 { + encoding convertto 乎 +} \x38\x43 -setup { set system [encoding system] -} -body { - encoding system iso8859-1 - encoding system + encoding system jis0208 } -cleanup { encoding system $system -} -result iso8859-1 +} + +# convertto ?-profile? : valid byte sequences + +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set printable [tcltest::Asciify $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str $bytes + testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix $bytes$suffix_bytes + testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str $prefix_bytes$bytes + testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes + } +} + +# convertto ?-profile? : invalid byte sequences +foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set printable [tcltest::Asciify $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] + set result [list $bytes] + # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch + # so glob it out in error message pattern for now. + set errorWithoutPrefix [list "unexpected character at index $failidx: *" -returnCodes error -match glob] + set errorWithPrefix [list "unexpected character at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob] + if {$ctrl eq {} || "solo" in $ctrl} { + if {$failidx == -1} { + set result [list $bytes] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str {*}$result + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + set result [list $bytes$suffix_bytes] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix {*}$result + } + if {$ctrl eq {} || "tail" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix_bytes$bytes] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str {*}$result + } + if {$ctrl eq {} || "middle" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix_bytes$bytes$suffix_bytes] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix {*}$result + } +} + +# convertto -failindex ?-profile? - valid data +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set printable [tcltest::Asciify $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str $bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix $bytes$suffix_bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str $prefix_bytes$bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes -1 $profile + } +} + +# convertto -failindex ?-profile? - invalid data +foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + if {"knownBug" in $ctrl} continue + set bytes [binary decode hex $hex] + set printable [tcltest::Asciify $str] + set prefix A + set suffix B + set prefixLen [string length [encoding convertto $enc $prefix]] + if {$ctrl eq {} || "solo" in $ctrl} { + testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str $bytes $failidx $profile + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + # If success expected + set result $bytes$suffix + } else { + # Failure expected + set result "" + } + testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix $result $failidx $profile + } + if {$ctrl eq {} || "tail" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$bytes + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str $result $expected_failidx $profile + } + if {$ctrl eq {} || "middle" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$bytes$suffix + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix $result $expected_failidx $profile + } +} + +test cmdAH-4.4.xx {convertto -profile strict} -constraints {testbytestring knownBug} -body { + # TODO - what does testbytestring even test? Invalid UTF8 in the Tcl_Obj bytes field + encoding convertto -profile strict utf-8 A[testbytestring \x80]B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} + +# +# encoding names 4.5.* +badnumargs cmdAH-4.5.1 {encoding names} {foo} +test cmdAH-4.5.2 {encoding names should include at least utf-8 and iso8859-1 and at least one more} -body { + set names [encoding names] + list [expr {"utf-8" in $names}] [expr {"iso8859-1" in $names}] [expr {[llength $names] > 2}] +} -result {1 1 1} + +# +# encoding profiles 4.6.* +badnumargs cmdAH-4.6.1 {encoding profiles} {foo} +test cmdAH-4.6.2 {encoding profiles} -body { + lsort [encoding profiles] +} -result {replace strict tcl8} + +# +# file command test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -324,19 +752,19 @@ test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform { test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo -} / +} //foo test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo/bar -} /foo +} //foo test cmdAH-8.16 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz} -} {/foo\/bar} +} {//foo\/bar} test cmdAH-8.17 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz/blat} -} {/foo\/bar/baz} +} {//foo\/bar/baz} test cmdAH-8.18 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /foo// @@ -468,7 +896,7 @@ test cmdAH-9.13 {Tcl_FileObjCmd: tail} testsetplatform { test cmdAH-9.14 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo -} foo +} {} test cmdAH-9.15 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo/bar @@ -966,7 +1394,7 @@ 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 0o000 + file attributes /tmp/tcl.foo.dir -permissions 0 file exists /tmp/tcl.foo.dir/file } -cleanup { file attributes /tmp/tcl.foo.dir -permissions 0o775 @@ -1079,10 +1507,10 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0 catch {file link -symbolic $linkfile $gorpfile} test cmdAH-23.1 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a -} -result {wrong # args: should be "file lstat name varName"} +} -result {could not read "a": no such file or directory} test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c -} -result {wrong # args: should be "file lstat name varName"} +} -result {wrong # args: should be "file lstat name ?varName?"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { @@ -1221,7 +1649,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] @@ -1246,7 +1674,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] @@ -1349,7 +1777,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 { @@ -1412,14 +1840,14 @@ catch {file attributes $gorpfile -permissions 0o765} # stat test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { - file stat _bogus_ -} -result {wrong # args: should be "file stat name varName"} + file stat +} -result {wrong # args: should be "file stat name ?varName?"} test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b -} -result {wrong # args: should be "file stat name varName"} +} -result {wrong # args: should be "file stat name ?varName?"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { unset -nocomplain stat - set stat(blocks) [set stat(blksize) {}] + array set stat {blocks {} blksize {}} } -body { file stat $gorpfile stat unset stat(blocks) stat(blksize); # Ignore these fields; not always set @@ -1512,6 +1940,16 @@ test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints } set res } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +test cmdAH-28.14 {Tcl_FileObjCmd: stat} -setup { + unset -nocomplain stat +} -body { + file stat $gorpfile stat + expr { + [lsort -stride 2 [array get stat]] + eq + [lsort -stride 2 [file stat $gorpfile]] + } +} -result {1} unset -nocomplain stat # type @@ -1539,7 +1977,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] @@ -1571,7 +2009,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} @@ -1703,6 +2141,62 @@ test cmdAH-32.6 {file tempfile - templates} -body { } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok + +test cmdAH-33.1 {file tempdir} -body { + file tempdir a b +} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"} +test cmdAH-33.2 {file tempdir} -body { + set d [file tempdir] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {tcl_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.3 {file tempdir} -body { + set d [file tempdir gorp] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {gorp_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.4 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.5 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/gorp]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.6 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/ +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} +test cmdAH-33.7 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/foobar +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} diff --git a/tests/cmdIL.test b/tests/cmdIL.test index e16bfcf..316a945 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -2,8 +2,8 @@ # 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. @@ -13,15 +13,16 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] source [file join [file dirname [info script]] internals.tcl] namespace import -force ::tcltest::internals::* - + test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} @@ -136,7 +137,7 @@ test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body { } -result {expected integer but got "foo"} test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body { lsort -stride 1 bar -} -result {stride length must be at least 2} +} -match glob -result {stride length must be between 2 and *} test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body { lsort -stride 2 {a b c} } -result {list size must be a multiple of the stride length} @@ -149,12 +150,27 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \x00 \x7F \x80 \uFFFF] +} [list \x00 \x7F \x80 \uFFFF] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + 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 \x00 \x7F \x80 \U01ffff \uFFFF] +} [list \x00 \x7F \x80 \uFFFF \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + 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" cannot select an element from any list} +} -returnCodes error -result {index "-2" out of range} test cmdIL-1.42 {lsort -stride and-index} -body { lsort -stride 2 -index -1-1 {a 2 b 1} -} -returnCodes error -result {index "-1-1" cannot select an element from any list} +} -returnCodes error -result {index "-1-1" out of range} +test cmdIL-1.43 {lsort -stride errors} -returnCodes error -body { + lsort -stride 4294967296 bar +} -match glob -result {stride length must be between 2 and *} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -164,7 +180,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} { @@ -216,13 +232,13 @@ test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated } -returnCodes error -result {element 4 missing from sublist "1 . c"} test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index -1-1 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {index "-1-1" cannot select an element from any list} +} -returnCodes error -result {index "-1-1" out of range} test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index -2 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {index "-2" cannot select an element from any list} +} -returnCodes error -result {index "-2" out of range} test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end-4 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {element -2 missing from sublist "1 . c"} +} -returnCodes error -result {element end-4 missing from sublist "1 . c"} test cmdIL-3.5.5 {SortCompare procedure, -index option} { lsort -index {} {a b} } {a b} @@ -231,13 +247,16 @@ test cmdIL-3.5.6 {SortCompare procedure, -index option} { } {a \{} test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end--1 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {index "end--1" cannot select an element from any list} +} -returnCodes error -result {index "end--1" out of range} test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end+1 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {index "end+1" cannot select an element from any list} +} -returnCodes error -result {index "end+1" out of range} test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end+2 {{1 . c} {2 . b} {3 . a}} -} -returnCodes error -result {index "end+2" cannot select an element from any list} +} -returnCodes error -result {index "end+2" out of range} +test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index 0 {{}} +} -returnCodes error -result {element 0 missing from sublist ""} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} @@ -254,8 +273,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body { lsort -integer {3 q} } -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { - lsort -integer {35 21 0x20 30 0o23 100 8} -} {8 0o23 21 30 0x20 35 100} + lsort -integer {35 21 0x20 0d30 0o23 100 8} +} {8 0o23 21 0d30 0x20 35 100} test cmdIL-3.12 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} @@ -380,16 +399,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 {} @@ -456,10 +475,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} { @@ -776,6 +795,52 @@ test cmdIL-7.8 {lreverse command - shared internalrep [Bug 1675044]} -setup { rename K {} } -result 1 +test cmdIL-8.1 {lremove command: error path} -returnCodes error -body { + lremove +} -result {wrong # args: should be "lremove list ?index ...?"} +test cmdIL-8.2 {lremove command: error path} -returnCodes error -body { + lremove {{}{}} +} -result {list element in braces followed by "{}" instead of space} +test cmdIL-8.3 {lremove command: error path} -returnCodes error -body { + lremove {a b c} gorp +} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?} +test cmdIL-8.4 {lremove command: no indices} -body { + lremove {a b c} +} -result {a b c} +test cmdIL-8.5 {lremove command: before start} -body { + lremove {a b c} -1 +} -result {a b c} +test cmdIL-8.6 {lremove command: after end} -body { + lremove {a b c} 3 +} -result {a b c} +test cmdIL-8.7 {lremove command} -body { + lremove {a b c} 0 +} -result {b c} +test cmdIL-8.8 {lremove command} -body { + lremove {a b c} 1 +} -result {a c} +test cmdIL-8.9 {lremove command} -body { + lremove {a b c} end +} -result {a b} +test cmdIL-8.10 {lremove command} -body { + lremove {a b c} end-1 +} -result {a c} +test cmdIL-8.11 {lremove command} -body { + lremove {a b c d e} 1 3 +} -result {a c e} +test cmdIL-8.12 {lremove command} -body { + lremove {a b c d e} 3 1 +} -result {a c e} +test cmdIL-8.13 {lremove command: same index twice} -body { + lremove {a b c d e} 2 2 +} -result {a b d e} +test cmdIL-8.14 {lremove command: same index twice} -body { + lremove {a b c d e} 3 end-1 +} -result {a b c e} +test cmdIL-8.15 {lremove command: many indices} -body { + lremove {a b c d e} 1 3 1 4 0 +} -result {c} + # This belongs in info test, but adding tests there breaks tests # that compute source file line numbers. test info-20.6 {Bug 3587651} -setup { @@ -784,8 +849,7 @@ test info-20.6 {Bug 3587651} -setup { }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { namespace delete my } -result 1 - - + # cleanup ::tcltest::cleanupTests return diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index e690002..37b8a0b 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -6,9 +6,9 @@ # 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. @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 66213f9..89947bb 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 { @@ -25,10 +25,6 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::testConstraint namespace import ::tcltest::test - if {[namespace which -command ::tcl::unsupported::timerate] ne ""} { - namespace import ::tcl::unsupported::timerate - } - proc ListGlobMatch {expected actual} { if {[llength $expected] != [llength $actual]} { return 0 @@ -63,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 0o000 + file attr . -permissions 0 pwd } -returnCodes error -cleanup { cd $cwd @@ -162,7 +158,7 @@ test cmdMZ-return-2.11 {return option handling} { } {3 {-code 3 -level 0}} test cmdMZ-return-2.12 {return option handling} -body { return -level 0 -code error -options {-code ok} -} -returnCodes ok -result {} +} -result {} test cmdMZ-return-2.13 {return option handling} -body { return -level 0 -code error -options {-code err} } -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer} @@ -239,7 +235,7 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrWin } -returnCodes error -body { - source a b + source a b c d e f } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { @@ -303,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 @@ -483,6 +479,23 @@ test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self insi list [lindex [timerate $m1 1000 5] 2] $x } {5 20} +test cmdMZ-try-1.0 { + + fix for issue 45b9faf103f2 + + [try] interaction with local variable names produces segmentation violation + +} -body { + ::apply {{} { + set cmd try + $cmd { + lindex 5 + } on ok res {} + set res + }} +} -result 5 + + # The tests for Tcl_WhileObjCmd are in while.test # cleanup diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 826fbc6..40dea76 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -6,8 +6,8 @@ # "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. @@ -17,14 +17,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] @@ -34,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) @@ -46,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) @@ -68,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 @@ -84,8 +79,8 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # procedures used below @@ -285,10 +280,10 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -309,10 +304,10 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 @@ -337,16 +332,9 @@ test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 - -# The following test is different for 32-bit versus 64-bit -# architectures because LONG_MIN is different - -test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} { expr {int(1<<63)} -} -9223372036854775808 -test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 @@ -377,10 +365,10 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -399,10 +387,10 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -430,10 +418,10 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body } -returnCodes error -match glob -result * test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -451,10 +439,10 @@ test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test compExpr-old-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} { set a 27 @@ -602,21 +590,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body { test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 2*T1() -} 246 -test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 -test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21, 37) -} 37 -test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21.2, 37) -} 37.0 -test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(-21.2, -17.5) -} -17.5 test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} diff --git a/tests/compExpr.test b/tests/compExpr.test index 7257726..eaef772 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -2,8 +2,8 @@ # 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. @@ -14,13 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] @@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 3*T1()-1 -} 368 -test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body { expr {atan2(1.0)} } -returnCodes error -match glob -result {not enough arguments for math function*} @@ -383,10 +371,46 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 + +proc extract {opcodes descriptor} { + set instructions [dict values [dict get $descriptor instructions]] + return [lmap i $instructions { + if {[lindex $i 0] in $opcodes} {string cat $i} else continue + }] +} + +test compExpr-8.1 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + + $ghi + }}] +} -result {loadStk loadStk add} +test compExpr-8.2 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + # + $ghi }}] +} -result loadStk +test compExpr-8.3 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\ + + $ghi + }}] +} -result loadStk +test compExpr-8.4 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\\ + + $ghi + }}] +} -result {loadStk loadStk add} # cleanup catch {unset a} catch {unset b} +catch {rename extract ""} ::tcltest::cleanupTests return diff --git a/tests/compile.test b/tests/compile.test index ac95c25..36b4f3a 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -5,8 +5,8 @@ # 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. @@ -16,8 +16,9 @@ if {"::tcltest" ni [namespace children]} { 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]] @@ -285,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 ] @@ -499,7 +500,7 @@ test compile-13.2 {TclCompileScript: testing expected nested scripts compilation # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack # boxes or systems, please don't decrease it (either provide a constraint) ti eval {foreach cmd {eval "if 1" try catch} { - set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd] + set c [gencode [expr {[tcl::build-info debug] ? 1500 : 1000}] $cmd] if 1 $c }} ti eval {set result} @@ -562,7 +563,8 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { apply {{} {catch {set a 1}; return}} } "" -for {set noComp 0} {$noComp <= 1} {incr noComp} { +# Do all tests once byte compiled and once with direct string evaluation +foreach noComp {0 1} { if {$noComp} { interp alias {} run {} testevalex @@ -650,26 +652,26 @@ test compile-16.18.$noComp {TclCompileScript: word expansion} -body { llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<20}] +} -result [expr {1<<20}] test compile-16.19.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<11}] x]} llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<22}] +} -result [expr {1<<22}] test compile-16.20.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<12}] x]} llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<24}] +} -result [expr {1<<24}] # This is the one that should cause overflow test compile-16.21.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<16}] x]} llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {wide(1)<<32}] +} -result [expr {wide(1)<<32}] test compile-16.22.$noComp { Bug 845412: TclCompileScript: word expansion not mandatory } -body { @@ -678,7 +680,7 @@ test compile-16.22.$noComp { run "ReturnResults [string repeat {x } 260]" } -constraints $constraints -cleanup { rename ReturnResults {} -} -returnCodes ok -result [string trim [string repeat {x } 260]] +} -result [string trim [string repeat {x } 260]] test compile-16.23.$noComp { Bug 1032805: defer parse error until run time } -constraints $constraints -body { @@ -690,7 +692,7 @@ test compile-16.23.$noComp { } } -cleanup { namespace delete x -} -returnCodes ok -result {syntax {}{}} +} -result {syntax {}{}} test compile-16.24.$noComp { Bug 1638414: bad list constant as first expanded term } -constraints $constraints -body { diff --git a/tests/concat.test b/tests/concat.test index 8ff5500..976591e 100644 --- a/tests/concat.test +++ b/tests/concat.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-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. diff --git a/tests/config.test b/tests/config.test index 15be790..50f03ce 100644 --- a/tests/config.test +++ b/tests/config.test @@ -5,9 +5,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-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. @@ -17,9 +17,9 @@ if {"::tcltest" ni [namespace children]} { 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 docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded} +} -match glob -result {*bindir,install bindir,runtime*docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime*scriptdir,install scriptdir,runtime*} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 diff --git a/tests/coroutine.test b/tests/coroutine.test index c60b568..c3023f7 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -4,7 +4,7 @@ # 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -755,6 +755,77 @@ test coroutine-7.12 {coro floor above street level #3008307} -body { rename boom {}; rename cc {}; rename c {} } -result {} + +test coroutine-7.13 { + issue f9800d52bd61f240 + + vwait is not NRE-enabled, and yieldto cannot find the right splicing spot +} -body { + coroutine c0 apply [list {} { + variable done + yield + yieldto c1 + after 0 c2 + vwait [namespace current]::done + } [namespace current]] + + coroutine c1 apply [list {} { + yield + tailcall c0 + } [namespace current]] + + coroutine c2 apply [list {} { + variable done + yield + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + set done 1 + } [namespace current]] + + after 0 [list [namespace which c0]] + vwait [namespace current]::done + return $done +} -result 1 + + +test coroutine-7.14 { + issue 5106fddd4400e5b9 + + failure to yieldto is not the same thing as not calling yieldto in the + first place +} -body { + variable done + variable done1 + + coroutine c0 ::apply [list {} { + yield + after 0 [list [namespace which c1]] + vwait [namespace current]::done1 + } [namespace current]] + + coroutine c1 ::apply [list {} { + variable done1 + yield + yieldto try "yieldto [list [info coroutine]]" on error {} " + ::set [list [namespace current]]::done1 failure + ::set [list [namespace current]]::done0 failure + " + set done1 success + + } [namespace current]] + after 1 [list [namespace which c0]] + vwait [namespace current]::done0 + if {[namespace which [namespace current]::c1] ne {}} { + # prior to the fix for 5106fddd4400e5b9, the nested yieldto turned into a + # tailcall which was eventutally activated, causing control to return to + # c1. After the fix, that doesn't happen, so if c1 still exists call it + # one final time to allow it to finish and clean up + rename c1 {} + } + return [list $done0 $done1] +} -result {failure failure} + + test coroutine-8.0.0 {coro inject executed} -body { coroutine demo apply {{} { foreach i {1 2} yield }} demo @@ -793,7 +864,152 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { set result } -result {inject-executed} -test coroutine-9.1 {coro type} { +test coroutine-9.1 {coroprobe with yield} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {}} +test coroutine-9.2 {coroprobe with yieldto} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {{a b} {c d}}} +test coroutine-9.3 {coroprobe errors} -setup { + catch {rename demo {}} +} -body { + coroprobe demo set i +} -returnCodes error -result {can only inject a probe command into a coroutine} +test coroutine-9.4 {coroprobe errors} -body { + proc demo {} { foreach i {1 2} yield } + coroprobe demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a probe command into a coroutine} +test coroutine-9.5 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.6 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.7 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo set +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "set varName ?newValue?"} +test coroutine-9.8 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2} +test coroutine-9.9 {coroprobe: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set f [info level],[info frame] + foreach i {1 2} yield + }} + coroprobe demo apply {{} { + upvar 1 f f + list [info coroutine] [info level] [info frame] $f + }} + } +} -cleanup { + interp delete $i +} -result {::demo 2 3 1,2} + +test coroutine-10.1 {coroinject with yield} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{yield x} y} {yield x}} +test coroutine-10.2 {coroinject stacking} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} + coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {x y} {yield x B yield x A}} +test coroutine-10.3 {coroinject with yieldto} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} + list $result [demo x mp] [demo y le] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} +test coroutine-10.4 {coroinject errors} -setup { + catch {rename demo {}} +} -body { + coroinject demo set i +} -returnCodes error -result {can only inject a command into a coroutine} +test coroutine-10.5 {coroinject errors} -body { + proc demo {} { foreach i {1 2} yield } + coroinject demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a command into a coroutine} +test coroutine-10.6 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.7 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.8 {coroinject errors in injected command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo apply {args {error "ERR: $args"}} + list [catch demo msg] $msg [catch demo msg] $msg +} -cleanup { + catch {rename demo {}} +} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} +test coroutine-10.9 {coroinject: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set l [info level] + set f [info frame] + lmap i {1 2} yield + }} + coroinject demo apply {{arg op val} { + global result + upvar 1 f f l l + lappend result [info coroutine] $arg $op $val + lappend result [info level] $l [info frame] $f + lappend result [yield $arg] + return [string toupper $val] + }} grill + list [demo ABC] [demo pqr] [demo def] $result + } +} -cleanup { + interp delete $i +} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} + +test coroutine-11.1 {coro type} { coroutine demo eval { yield yield "PHASE 1" @@ -803,19 +1019,19 @@ test coroutine-9.1 {coro type} { list [demo] [::tcl::unsupported::corotype demo] \ [demo] [::tcl::unsupported::corotype demo] [demo] } {{PHASE 1} yield {PHASE 2} yieldto active} -test coroutine-9.2 {coro type} -setup { +test coroutine-11.2 {coro type} -setup { catch {rename nosuchcommand ""} } -returnCodes error -body { ::tcl::unsupported::corotype nosuchcommand } -result {can only get coroutine type of a coroutine} -test coroutine-9.3 {coro type} -returnCodes error -body { +test coroutine-11.3 {coro type} -returnCodes error -body { proc notacoroutine {} {} ::tcl::unsupported::corotype notacoroutine } -returnCodes error -cleanup { rename notacoroutine {} } -result {can only get coroutine type of a coroutine} -test coroutine-10.1 {coroutine general introspection} -setup { +test coroutine-12.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { diff --git a/tests/dcall.test b/tests/dcall.test index 7d86135..e407e48 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -4,9 +4,9 @@ # 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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 fe9ec33..1515675 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -5,7 +5,7 @@ # 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. @@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} { } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -returnCodes error -result {missing value to go with key} -test dict-4.13a {dict replace command: type check is mandatory} { - catch {dict replace { a b c d e }} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} @@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} { } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in dict} -test dict-4.17a {dict replace command: type check is mandatory} { - catch {dict replace " a b \{c d "} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY BRACE} +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] @@ -2055,6 +2047,111 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} dict update item item item two two {} }} } {} + +set dict dict; # Used to force interpretation, not compilation +test dict-26.1 {dict getdef command} -body { + dict getdef {a b} a c +} -result b +test dict-26.2 {dict getdef command} -body { + dict getdef {a b} b c +} -result c +test dict-26.3 {dict getdef command} -body { + dict getdef {a {b c}} a b d +} -result c +test dict-26.4 {dict getdef command} -body { + dict getdef {a {b c}} a c d +} -result d +test dict-26.5 {dict getdef command} -body { + dict getdef {a {b c}} b c d +} -result d +test dict-26.6 {dict getdef command} -returnCodes error -body { + dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getdef command} -returnCodes error -body { + dict getdef +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.8 {dict getdef command} -returnCodes error -body { + dict getdef {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.9 {dict getdef command} -returnCodes error -body { + dict getdef {} {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getdef {a b c} d e +} -result {missing value to go with key} +test dict-26.11 {dict getdef command} -body { + $dict getdef {a b} a c +} -result b +test dict-26.12 {dict getdef command} -body { + $dict getdef {a b} b c +} -result c +test dict-26.13 {dict getdef command} -body { + $dict getdef {a {b c}} a b d +} -result c +test dict-26.14 {dict getdef command} -body { + $dict getdef {a {b c}} a c d +} -result d +test dict-26.15 {dict getdef command} -body { + $dict getdef {a {b c}} b c d +} -result d +test dict-26.16 {dict getdef command} -returnCodes error -body { + $dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getdef {a b c} d e +} -result {missing value to go with key} + +test dict-27.1 {dict getwithdefault command} -body { + dict getwithdefault {a b} a c +} -result b +test dict-27.2 {dict getwithdefault command} -body { + dict getwithdefault {a b} b c +} -result c +test dict-27.3 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.4 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.5 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.6 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-27.7 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.8 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.9 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.10 {dict getdef command} -returnCodes error -body { + dict getwithdefault {a b c} d e +} -result {missing value to go with key} +test dict-27.11 {dict getwithdefault command} -body { + $dict getwithdefault {a b} a c +} -result b +test dict-27.12 {dict getwithdefault command} -body { + $dict getwithdefault {a b} b c +} -result c +test dict-27.13 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.14 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.15 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.16 {dict getwithdefault command} -returnCodes error -body { + $dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-27.17 {dict getdef command} -returnCodes error -body { + $dict getwithdefault {a b c} d e +} -result {missing value to go with key} # cleanup ::tcltest::cleanupTests diff --git a/tests/dstring.test b/tests/dstring.test index cb1cc4f..7c9d9f6 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -4,9 +4,9 @@ # 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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]} { @@ -425,10 +425,13 @@ test dstring-4.3 {truncation} -constraints testdstring -setup { # Pass a negative length to Tcl_DStringSetLength(); # if not caught, causing '\0' to be written out-of-bounds, # try corrupting dsPtr->length which begins - # 2*sizeof(int) bytes before dsPtr->staticSpace[], + # 2*sizeof(Tcl_Size) bytes before dsPtr->staticSpace[], # so that the result is -256 (on little endian systems) - # rather than e.g. -8. - testdstring trunc -8 + # rather than e.g. -8 or -16. + # (sizeof(Tcl_Size) does not seem to be available via Tcl, + # so assume sizeof(Tcl_Size) == sizeof(void*) for Tcl 9.) + testdstring trunc [expr {-2*([package vsatisfies $tcl_version 9.0-] + ? $tcl_platform(pointerSize) : 4)}] list [testdstring get] [testdstring length] } -cleanup { testdstring free @@ -520,6 +523,45 @@ test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body { } -cleanup { testdstring free } -result {{} {This is a specially-allocated stringz}} + +test dstring-7.1 {copying to Tcl_Obj} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append xyz -1 + list [testdstring toobj] [testdstring length] +} -cleanup { + testdstring free +} -result {xyz 0} +test dstring-7.2 {copying to a Tcl_Obj} -constraints testdstring -setup { + testdstring free + unset -nocomplain a +} -body { + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring toobj] + testdstring append abc -1 + list $a [testdstring get] +} -cleanup { + testdstring free +} -result {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + # cleanup if {[testConstraint testdstring]} { diff --git a/tests/encoding.test b/tests/encoding.test index dc50f24..da2dac3 100644 --- a/tests/encoding.test +++ b/tests/encoding.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) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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. @@ -13,14 +13,17 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } + namespace eval ::tcl::test::encoding { variable x catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] } +source [file join [file dirname [info script]] tcltests.tcl] + proc toutf {args} { variable x lappend x "toutf $args" @@ -37,10 +40,8 @@ proc runtests {} { testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint teststringbytes [llength [info commands teststringbytes]] -testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] -testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] testConstraint exec [llength [info commands exec]] -testConstraint testgetdefenc [llength [info commands testgetdefenc]] +testConstraint testgetencpath [llength [info commands testgetencpath]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -65,12 +66,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] @@ -78,10 +79,10 @@ 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 @@ -104,6 +105,14 @@ test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup { } -cleanup { fconfigure stdout -encoding $old } -result {jis0208} +test encoding-3.3 {fconfigure -profile} -setup { + set old [fconfigure stdout -profile] +} -body { + fconfigure stdout -profile replace + fconfigure stdout -profile +} -cleanup { + fconfigure stdout -profile $old +} -result replace test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { cd [makeDirectory tmp] @@ -138,7 +147,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 @@ -170,7 +179,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 @@ -179,7 +188,7 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] -} "512 \u4E4E" +} "512 乎" test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] @@ -192,13 +201,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 @@ -212,7 +221,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 @@ -222,44 +231,32 @@ test encoding-10.1 {Tcl_UtfToExternal} { return $x } "ab\x8C\xC1g" -proc viewable {str} { - set res "" - foreach c [split $str {}] { - if {[string is print $c] && [string is ascii $c]} { - append res $c - } else { - append res "\\u[format %4.4X [scan $c %c]]" - } - } - return "$str ($res)" -} - test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { set system [encoding system] set path [encoding dirs] 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 +} ｡ 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 +} 乎 test encoding-11.5 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022 \u4E4E] -} [viewable "\x1B\$B8C\x1B(B"] + encoding convertto iso2022 乎 +} \x1B\$B8C\x1B(B test encoding-11.5.1 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022-jp \u4E4E] -} [viewable "\x1B\$B8C\x1B(B"] + encoding convertto iso2022-jp 乎 +} \x1B\$B8C\x1B(B test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] @@ -273,7 +270,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] @@ -282,45 +279,49 @@ 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} { + encoding convertto utf-16le 😹 +} =Ø9Þ +test encoding-11.9 {encoding: extended Unicode UTF-16} { + encoding convertto utf-16be 😹 +} Ø=Þ9 +test encoding-11.10 {encoding: extended Unicode UTF-32} { + encoding convertto utf-32le 😹 +} 9\xF6\x01\x00 +test encoding-11.11 {encoding: extended Unicode UTF-32} { + encoding convertto utf-32be 😹 +} \x00\x01\xF69 # 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?\u0120 + set x [encoding convertto iso8859-3 Ġ] + append x [encoding convertto -profile tcl8 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\u0120g + 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] + set x [encoding convertto shiftjis ab乎g] append x [encoding convertfrom shiftjis ab\x8C\xC1g] -} ab\x8C\xC1gab\u4E4Eg +} "ab\x8C\xC1gab乎g" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { - set x [encoding convertto jis0208 \u4E4E\u03B1] + set x [encoding convertto jis0208 乎α] append x [encoding convertfrom jis0208 8C&A] -} 8C&A\u4E4E\u03B1 +} "8C&A乎α" test encoding-12.5 {LoadTableEncoding: symbol encoding} { - set x [encoding convertto symbol \u03B3] + set x [encoding convertto symbol γ] append x [encoding convertto symbol g] append x [encoding convertfrom symbol g] -} gg\u03B3 -test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 { - encoding convertto iso8859-3 \U010000 -} ? +} "ggγ" test encoding-13.1 {LoadEscapeTable} { - viewable [set x [encoding convertto iso2022 ab\u4E4E\u68D9g]] -} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"] - -test encoding-14.1 {BinaryProc} { - encoding convertto identity \x12\x34\x56\xff\x69 -} "\x12\x34\x56\xc3\xbf\x69" + encoding convertto iso2022 ab乎棙g +} ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg test encoding-15.1 {UtfToUtfProc} { - encoding convertto utf-8 \xA3 + encoding convertto utf-8 £ } "\xC2\xA3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z @@ -335,113 +336,315 @@ 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 \uD83D\uDE02" +} -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 \uD83D\uDE02" +} "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] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { - set x \uDE02\uD83D\xE9 - set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + set x \uDE02\uD83Dé + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto utf-8 \uDE02\uD83DX] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { - set x \uDE02\xE9 - set y [encoding convertto utf-8 \uDE02\xE9] + set x \uDE02é + set y [encoding convertto -profile tcl8 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 -profile tcl8 utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto utf-8 \uDE02Y] + set y [encoding convertto -profile tcl8 utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto utf-8 \uDA02Y] + set y [encoding convertto -profile tcl8 utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto utf-8 \uDE02] + set y [encoding convertto -profile tcl8 utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto utf-8 \uDA02] + set y [encoding convertto -profile tcl8 utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom -profile tcl8 utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" +test encoding-15.17 {UtfToUtfProc emoji character output} { + set x 😂 + set y [encoding convertto utf-8 😂] + binary scan $y H* z + list [string length $y] $z +} {4 f09f9882} +test encoding-15.18 {UtfToUtfProc CESU-8 6-byte sequence} { + set y [encoding convertto cesu-8 \U10000] + binary scan $y H* z + list [string length $y] $z +} {6 eda080edb080} +test encoding-15.19 {UtfToUtfProc CESU-8 upper surrogate} { + set y [encoding convertto cesu-8 \uD800] + binary scan $y H* z + list [string length $y] $z +} {3 eda080} +test encoding-15.20 {UtfToUtfProc CESU-8 lower surrogate} { + set y [encoding convertto cesu-8 \uDC00] + binary scan $y H* z + list [string length $y] $z +} {3 edb080} +test encoding-15.21 {UtfToUtfProc CESU-8 noncharacter} { + set y [encoding convertto cesu-8 \uFFFF] + binary scan $y H* z + list [string length $y] $z +} {3 efbfbf} +test encoding-15.22 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} { + set y [encoding convertto cesu-8 \x80] + binary scan $y H* z + list [string length $y] $z +} {2 c280} +test encoding-15.23 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} { + set y [encoding convertto cesu-8 \u100] + binary scan $y H* z + list [string length $y] $z +} {2 c480} +test encoding-15.24 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} { + set y [encoding convertto cesu-8 \u3FF] + binary scan $y H* z + list [string length $y] $z +} {2 cfbf} +test encoding-15.25 {UtfToUtfProc CESU-8} { + encoding convertfrom cesu-8 \x00 +} \x00 +test encoding-15.26 {UtfToUtfProc CESU-8} { + encoding convertfrom cesu-8 \xC0\x80 +} \x00 +test encoding-15.27 {UtfToUtfProc -profile strict CESU-8} { + encoding convertfrom -profile strict cesu-8 \x00 +} \x00 +test encoding-15.28 {UtfToUtfProc -profile strict CESU-8} -body { + encoding convertfrom -profile strict cesu-8 \xC0\x80 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} +test encoding-15.29 {UtfToUtfProc CESU-8} { + encoding convertto cesu-8 \x00 +} \x00 +test encoding-15.30 {UtfToUtfProc -profile strict CESU-8} { + encoding convertto -profile strict cesu-8 \x00 +} \x00 +test encoding-15.31 {UtfToUtfProc -profile strict CESU-8 (bytes F0-F4 are invalid)} -body { + encoding convertfrom -profile strict cesu-8 \xF1\x86\x83\x9C +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'} -test encoding-16.1 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode NN] - list $val [format %X [scan $val %c]] -} -result "\u4E4E 4E4E" -test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { - set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"] +test encoding-16.1 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 NN] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.2 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] } -result "\U460DC 460dc" -test encoding-16.3 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode "\xDC\xDC"] - list $val [format %X [scan $val %c]] -} -result "\uDCDC DCDC" -test encoding-16.4 {UnicodeToUtfProc, bug [d19fe0a5b]} -body { - encoding convertfrom unicode "\x41\x41\x41" +test encoding-16.3 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\uDCDC dcdc" +test encoding-16.4 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 NN] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.5 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\U460DC 460dc" +test encoding-16.6 {Utf32ToUtfProc} -body { + set val [encoding convertfrom utf-32le NN\0\0] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.7 {Utf32ToUtfProc} -body { + set val [encoding convertfrom utf-32be \0\0NN] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.8 {Utf32ToUtfProc} -body { + set val [encoding convertfrom -profile tcl8 utf-32 \x41\x00\x00\x41] + list $val [format %x [scan $val %c]] +} -result "\uFFFD fffd" +test encoding-16.9 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xD8\x00\x00 +} -result \uD800 +test encoding-16.10 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xDC\x00\x00 +} -result \uDC00 +test encoding-16.11 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 +} -result \uD800\uDC00 +test encoding-16.12 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 +} -result \uDC00\uD800 +test encoding-16.13 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xD8 +} -result \uD800 +test encoding-16.14 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xDC +} -result \uDC00 +test encoding-16.15 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xD8\x00\xDC +} -result \uD800\uDC00 +test encoding-16.16 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xDC\x00\xD8 +} -result \uDC00\uD800 +test encoding-16.17 {Utf32ToUtfProc} -body { + list [encoding convertfrom -profile strict -failindex idx utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00] [set idx] +} -result {A 4} + +test encoding-16.18 { + Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 +} -body { + apply [list {} { + for {set i 0xD800} {$i < 0xDBFF} {incr i} { + for {set j 0xDC00} {$j < 0xDFFF} {incr j} { + set string [binary format S2 [list $i $j]] + set status [catch { + set decoded [encoding convertfrom utf-16be $string] + set encoded [encoding convertto utf-16be $decoded] + }] + if {$status || ( $encoded ne $string )} { + return [list [format %x $i] [format %x $j]] + } + } + } + return done + } [namespace current]] +} -result done +test encoding-16.19 {Utf16ToUtfProc, bug [d19fe0a5b]} -body { + encoding convertfrom utf-16 "\x41\x41\x41" } -result \u4141\uFFFD -test encoding-16.5 {UnicodeToUtfProc, bug [d19fe0a5b]} -constraints ucs2 -body { - encoding convertfrom unicode "\xD8\xD8" +test encoding-16.20 {Utf16ToUtfProc, bug [d19fe0a5b]} -constraints deprecated -body { + encoding convertfrom utf-16 "\xD8\xD8" } -result \uD8D8 +test encoding-16.21 {Utf16ToUtfProc, bug [d19fe0a5b]} -body { + encoding convertfrom utf-32 "\x00\x00\x00\x00\x41\x41" +} -result \x00\uFFFD +test encoding-16.22 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body { + encoding convertfrom -profile strict utf-16le \x00\xD8 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'} +test encoding-16.23 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body { + encoding convertfrom -profile strict utf-16le \x00\xDC +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'} +test encoding-16.24 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32 "\xFF\xFF\xFF\xFF" +} -result \uFFFD +test encoding-16.25 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32 "\x01\x00\x00\x01" +} -result \uFFFD -test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { - encoding convertto unicode "\U460DC" +test encoding-17.1 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -test encoding-17.2 {UtfToUnicodeProc} -body { - encoding convertto unicode "\uDCDC" +test encoding-17.2 {UtfToUcs2Proc, invalid testcase, see [5607d6482c]} -constraints deprecated -body { + encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] +} -result "\uFFFD" +test encoding-17.3 {UtfToUtf16Proc} -body { + encoding convertto -profile tcl8 utf-16be "\uDCDC" } -result "\xDC\xDC" -test encoding-17.3 {UtfToUnicodeProc} -body { - encoding convertto unicode "\uD8D8" +test encoding-17.4 {UtfToUtf16Proc} -body { + encoding convertto -profile tcl8 utf-16le "\uD8D8" } -result "\xD8\xD8" +test encoding-17.5 {UtfToUtf16Proc} -body { + encoding convertto utf-32le "\U460DC" +} -result "\xDC\x60\x04\x00" +test encoding-17.6 {UtfToUtf16Proc} -body { + encoding convertto utf-32be "\U460DC" +} -result "\x00\x04\x60\xDC" +test encoding-17.7 {UtfToUtf16Proc} -body { + encoding convertto -profile strict utf-16be "\uDCDC" +} -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'} +test encoding-17.8 {UtfToUtf16Proc} -body { + encoding convertto -profile strict utf-16le "\uD8D8" +} -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'} +test encoding-17.9 {Utf32ToUtfProc} -body { + encoding convertfrom -profile strict utf-32 "\xFF\xFF\xFF\xFF" +} -returnCodes error -result {unexpected byte sequence starting at index 0: '\xFF'} +test encoding-17.10 {Utf32ToUtfProc} -body { + encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF" +} -result \uFFFD +test encoding-17.11 {Utf32ToUtfProc} -body { + encoding convertfrom -profile strict utf-32le "\x00\xD8\x00\x00" +} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'} +test encoding-17.12 {Utf32ToUtfProc} -body { + encoding convertfrom -profile strict utf-32le "\x00\xDC\x00\x00" +} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'} -test encoding-18.1 {TableToUtfProc on invalid input} -body { +test encoding-18.1 {TableToUtfProc on invalid input} -constraints deprecated -body { list [catch {encoding convertto jis0208 \\} res] $res } -result {0 !)} +test encoding-18.2 {TableToUtfProc on invalid input with -profile strict} -body { + list [catch {encoding convertto -profile strict jis0208 \\} res] $res +} -result {1 {unexpected character at index 0: 'U+00005C'}} +test encoding-18.3 {TableToUtfProc on invalid input with -profile strict -failindex} -body { + list [catch {encoding convertto -profile strict -failindex pos jis0208 \\} res] $res $pos +} -result {0 {} 0} +test encoding-18.4 {TableToUtfProc on invalid input with -failindex -profile strict} -body { + list [catch {encoding convertto -failindex pos -profile strict jis0208 \\} res] $res $pos +} -result {0 {} 0} +test encoding-18.5 {TableToUtfProc on invalid input with -failindex} -body { + list [catch {encoding convertto -failindex pos jis0208 \\} res] $res $pos +} -result {0 !) -1} +test encoding-18.6 {TableToUtfProc on invalid input with -profile tcl8} -body { + list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res +} -result {0 !)} -test encoding-19.1 {TableFromUtfProc} { -} {} +test encoding-19.1 {TableFromUtfProc} -body { + encoding convertfrom ascii AÁ +} -result AÁ +test encoding-19.2 {TableFromUtfProc} -body { + encoding convertfrom -profile tcl8 ascii AÁ +} -result AÁ +test encoding-19.3 {TableFromUtfProc} -body { + encoding convertfrom -profile strict ascii AÁ +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xC1'} +test encoding-19.4 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx ascii AÁ] [set idx] +} -result [list A\xC1 -1] +test encoding-19.5 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx -profile strict ascii A\xC1] [set idx] +} -result {A 1} +test encoding-19.6 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx -profile strict ascii AÁB] [set idx] +} -result {A 1} test encoding-20.1 {TableFreefProc} { } {} @@ -459,11 +662,11 @@ casino_japanese@___.com \x1B\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\ \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] @@ -525,20 +728,20 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec { } {} test encoding-24.2 {EscapeFreeProc on open channels} {exec} { # Bug #524674 output - viewable [runInSubprocess { + 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" 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]"] @@ -546,33 +749,135 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { set count [gets $f line] close $f removeFile iso2022.tcl - list $count [viewable $line] -} [list 3 "\u4E4E\u4E5E\u4E5F (\\u4E4E\\u4E5E\\u4E5F)"] + list $count $line +} [list 3 乎乞也] test encoding-24.4 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x80"] + string length [encoding convertfrom -profile tcl8 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 -profile tcl8 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 -profile tcl8 utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom -profile tcl8 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 -profile tcl8 utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xEF\xBF\xBF"] +} 1 +test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { + encoding convertfrom utf-8 "\xC0\x81" +} -result \xC0\x81 +test encoding-24.13 {Parse valid or invalid utf-8} -constraints deprecated -body { + encoding convertfrom utf-8 "\xC1\xBF" +} -result \xC1\xBF +test encoding-24.14 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 +test encoding-24.15 {Parse valid or invalid utf-8} -constraints deprecated -body { + encoding convertfrom utf-8 "Z\xE0\x80" +} -result Z\xE0\u20AC +test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\u4343\x80"] +} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃' (U+004343)} +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80"] +} -result "Z\xC3\xA0\xE2\x82\xAC" +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] +} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" +test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { + encoding convertto utf-8 "ZX\uD800" +} -result ZX\xED\xA0\x80 +test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -body { + encoding convertfrom -profile tcl8 "\x20" +} -result {wrong # args: should be "::tcl::encoding::convertfrom ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertfrom data"} -returnCodes error +test encoding-24.21 {Parse with -profile tcl8 but without providing encoding} -body { + string length [encoding convertto -profile tcl8 "\x20"] +} -result {wrong # args: should be "::tcl::encoding::convertto ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertto data"} -returnCodes error +test encoding-24.22 {Syntax error, two encodings} -body { + encoding convertfrom iso8859-1 utf-8 "ZX\uD800" +} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error +test encoding-24.23 {Syntax error, two encodings} -body { + encoding convertto iso8859-1 utf-8 "ZX\uD800" +} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error +test encoding-24.24 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xC0\x80\x00\x00" +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} +test encoding-24.25 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\x40\x80\x00\x00" +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'} +test encoding-24.26 {Parse valid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xF1\x80\x80\x80" +} -result \U40000 +test encoding-24.27 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xF0\x80\x80\x80" +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'} +test encoding-24.28 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xFF\x00\x00" +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'} +test encoding-24.29 {Parse invalid utf-8} -body { + encoding convertfrom utf-8 \xEF\xBF\xBF +} -result \uFFFF +test encoding-24.30 {Parse noncharacter with -profile strict} -body { + encoding convertfrom -profile strict utf-8 \xEF\xBF\xBF +} -result \uFFFF +test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body { + encoding convertfrom -profile tcl8 utf-8 \xEF\xBF\xBF +} -result \uFFFF +test encoding-24.32 {Try to generate invalid utf-8} -body { + encoding convertto utf-8 \uFFFF +} -result \xEF\xBF\xBF +test encoding-24.33 {Try to generate noncharacter with -profile strict} -body { + encoding convertto -profile strict utf-8 \uFFFF +} -result \xEF\xBF\xBF +test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body { + encoding convertto -profile tcl8 utf-8 \uFFFF +} -result \xEF\xBF\xBF +test encoding-24.35 {Parse invalid utf-8} -constraints deprecated -body { + encoding convertfrom utf-8 \xED\xA0\x80 +} -result \uD800 +test encoding-24.36 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 \xED\xA0\x80 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} +test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body { + encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80 +} -result \uD800 +test encoding-24.38 {Try to generate invalid utf-8} -constraints deprecated -body { + encoding convertto utf-8 \uD800 +} -result \xED\xA0\x80 +test encoding-24.39 {Try to generate invalid utf-8 with -profile strict} -body { + encoding convertto -profile strict utf-8 \uD800 +} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} +test encoding-24.40 {Try to generate invalid utf-8 with -profile tcl8} -body { + encoding convertto -profile tcl8 utf-8 \uD800 +} -result \xED\xA0\x80 +test encoding-24.41 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 \xED\xA0\x80\xED\xB0\x80 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} +test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { + encoding convertfrom -profile tcl8 utf-8 \xF0\x80\x80\x80 +} -result \xF0\u20AC\u20AC\u20AC +test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { + encoding convertfrom -profile tcl8 utf-8 \x80 +} -result \u20AC +test encoding-24.44 {Try to generate invalid ucs-2 with -profile strict} -body { + encoding convertto -profile strict ucs-2 \uD800 +} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} +test encoding-24.45 {Try to generate invalid ucs-2 with -profile strict} -body { + encoding convertto -profile strict ucs-2 \U10000 +} -returnCodes 1 -result {unexpected character at index 0: 'U+010000'} file delete [file join [temporaryDirectory] iso2022.txt] @@ -696,15 +1001,15 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { } } -test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc +test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints { + testgetencpath } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origPath [testgetencpath] + testsetencpath slappy } -body { - testgetdefenc + testgetencpath } -cleanup { - testsetdefenc $origDir + testsetencpath $origPath } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] @@ -727,55 +1032,98 @@ test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body { test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { - incr count - encoding convertto $name $string + if {$name ne "unicode"} { + incr count + } + encoding convertto -profile tcl8 $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. llength $name } return $count -} -result 83 +} -result 91 runtests test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { testencoding } -body { - # Note - buffers are initialized to \xff - list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 1} result] $result -} -result [list 0 [list nospace {} \xff]] + # Note - buffers are initialized to \xFF + list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1} result] $result +} -result [list 0 [list nospace {} \xFF]] test encoding-bug-183a1adcc0-2 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { testencoding } -body { - # Note - buffers are initialized to \xff - list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 0} result] $result + # Note - buffers are initialized to \xFF + list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 0} result] $result } -result [list 0 [list nospace {} {}]] test encoding-bug-183a1adcc0-3 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { testencoding } -body { - # Note - buffers are initialized to \xff - list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 2} result] $result + # Note - buffers are initialized to \xFF + list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 2} result] $result } -result [list 0 [list nospace {} \x00\x00]] test encoding-bug-183a1adcc0-4 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { testencoding } -body { - # Note - buffers are initialized to \xff - list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 3} result] $result -} -result [list 0 [list nospace {} \x00\x00\xff]] + # Note - buffers are initialized to \xFF + list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 3} result] $result +} -result [list 0 [list nospace {} \x00\x00\xFF]] test encoding-bug-183a1adcc0-5 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { - testencoding ucs2 + testencoding } -body { - # Note - buffers are initialized to \xff - list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 4} result] $result + list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 4} result] $result } -result [list 0 [list ok {} [expr {$::tcl_platform(byteOrder) eq "littleEndian" ? "\x41\x00" : "\x00\x41"}]\x00\x00]] } +test encoding-29.0 {get encoding nul terminator lengths} -constraints { + testencoding +} -body { + list \ + [testencoding nullength ascii] \ + [testencoding nullength utf-16] \ + [testencoding nullength utf-32] \ + [testencoding nullength gb12345] \ + [testencoding nullength ksc5601] +} -result {1 2 4 2 2} + +test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { + encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby +} -result x\uFFFDy +test encoding-bug-6a3e2cb0f0-2 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { + encoding convertfrom -profile strict iso2022-jp x\x1B\x7Aaby +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x1B'} +test encoding-bug-6a3e2cb0f0-3 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { + encoding convertfrom -profile replace iso2022-jp x\x1B\x7Aaby +} -result x\uFFFDy + +test encoding-bug-66ffafd309-1-tcl8 {Bug [66ffafd309] - truncated DBCS} -body { + encoding convertfrom -profile tcl8 gb12345 x +} -result x +test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body { + encoding convertfrom -profile strict gb12345 x +} -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error +test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body { + encoding convertfrom -profile replace gb12345 x +} -result \uFFFD +test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body { + # Not truncated but invalid + encoding convertfrom -profile tcl8 jis0208 \x78\x79 +} -result \x78\x79 +test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body { + # Not truncated but invalid + encoding convertfrom -profile strict jis0208 \x78\x79 +} -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error +test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body { + # Not truncated but invalid + encoding convertfrom -profile replace jis0208 \x78\x79 +} -result \uFFFD\uFFFD # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl new file mode 100644 index 0000000..3961917 --- /dev/null +++ b/tests/encodingVectors.tcl @@ -0,0 +1,655 @@ +# This file contains test vectors for verifying various encodings. They are +# stored in a common file so that they can be sourced into the various test +# modules that are dependent on encodings. This file contains statically defined +# test vectors. In addition, it sources the ICU-generated test vectors from +# icuUcmTests.tcl. +# +# Note that sourcing the file will reinitialize any existing encoding test +# vectors. +# + +# List of defined encoding profiles +set encProfiles {tcl8 strict replace} +set encDefaultProfile tcl8; # Should reflect the default from implementation + +# encValidStrings - Table of valid strings. +# +# Each row is <ENCODING STR BYTES CTRL COMMENT> +# The pair <ENCODING,STR> should be unique for generated test ids to be unique. +# STR is a string that can be encoded in the encoding ENCODING resulting +# in the byte sequence BYTES. The CTRL field is a list that controls test +# generation. It may contain zero or more of `solo`, `lead`, `tail` and +# `middle` indicating that the generated tests should include the string +# by itself, as the lead of a longer string, as the tail of a longer string +# and in the middle of a longer string. If CTRL is empty, it is treated as +# containing all four of the above. The CTRL field may also contain the +# words knownBug or knownW3C which will cause the test generation for that +# vector to be skipped. +# +# utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +set encValidStrings {}; # Reset the table + +lappend encValidStrings {*}{ + ascii \u0000 00 {} {Lowest ASCII} + ascii \u007F 7F {} {Highest ASCII} + ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly} + ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly} + + utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1} + utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1} + utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2} + utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2} + utf-8 \u0800 E0A080 {} {Unicode Table 3.7 Row 3} + utf-8 \u0FFF E0BFBF {} {Unicode Table 3.7 Row 3} + utf-8 \u1000 E18080 {} {Unicode Table 3.7 Row 4} + utf-8 \uCFFF ECBFBF {} {Unicode Table 3.7 Row 4} + utf-8 \uD000 ED8080 {} {Unicode Table 3.7 Row 5} + utf-8 \uD7FF ED9FBF {} {Unicode Table 3.7 Row 5} + utf-8 \uE000 EE8080 {} {Unicode Table 3.7 Row 6} + utf-8 \uFFFF EFBFBF {} {Unicode Table 3.7 Row 6} + utf-8 \U10000 F0908080 {} {Unicode Table 3.7 Row 7} + utf-8 \U3FFFF F0BFBFBF {} {Unicode Table 3.7 Row 7} + utf-8 \U40000 F1808080 {} {Unicode Table 3.7 Row 8} + utf-8 \UFFFFF F3BFBFBF {} {Unicode Table 3.7 Row 8} + utf-8 \U100000 F4808080 {} {Unicode Table 3.7 Row 9} + utf-8 \U10FFFF F48FBFBF {} {Unicode Table 3.7 Row 9} + utf-8 A\u03A9\u8A9E\U00010384 41CEA9E8AA9EF0908E84 {} {Unicode 2.5} + + utf-16le \u0000 0000 {} {Lowest code unit} + utf-16le \uD7FF FFD7 {} {Below high surrogate range} + utf-16le \uE000 00E0 {} {Above low surrogate range} + utf-16le \uFFFF FFFF {} {Highest code unit} + utf-16le \U010000 00D800DC {} {First surrogate pair} + utf-16le \U10FFFF FFDBFFDF {} {First surrogate pair} + utf-16le A\u03A9\u8A9E\U00010384 4100A9039E8A00D884DF {} {Unicode 2.5} + + utf-16be \u0000 0000 {} {Lowest code unit} + utf-16be \uD7FF D7FF {} {Below high surrogate range} + utf-16be \uE000 E000 {} {Above low surrogate range} + utf-16be \uFFFF FFFF {} {Highest code unit} + utf-16be \U010000 D800DC00 {} {First surrogate pair} + utf-16be \U10FFFF DBFFDFFF {} {First surrogate pair} + utf-16be A\u03A9\u8A9E\U00010384 004103A98A9ED800DF84 {} {Unicode 2.5} + + utf-32le \u0000 00000000 {} {Lowest code unit} + utf-32le \uFFFF FFFF0000 {} {Highest BMP} + utf-32le \U010000 00000100 {} {First supplementary} + utf-32le \U10FFFF ffff1000 {} {Last supplementary} + utf-32le A\u03A9\u8A9E\U00010384 41000000A90300009E8A000084030100 {} {Unicode 2.5} + + utf-32be \u0000 00000000 {} {Lowest code unit} + utf-32be \uFFFF 0000FFFF {} {Highest BMP} + utf-32be \U010000 00010000 {} {First supplementary} + utf-32be \U10FFFF 0010FFFF {} {Last supplementary} + utf-32be A\u03A9\u8A9E\U00010384 00000041000003A900008A9E00010384 {} {Unicode 2.5} +} + +# encInvalidBytes - Table of invalid byte sequences +# These are byte sequences that should appear for an encoding. Each row is +# of the form +# <ENCODING BYTES PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT> +# The triple <ENCODING,BYTES,PROFILE> should be unique for test ids to be +# unique. BYTES is a byte sequence that is invalid. EXPECTEDRESULT is the +# expected string when the bytes are decoded using the PROFILE profile. +# FAILINDEX gives the expected index of the invalid byte under that profile. The +# CTRL field is a list that controls test generation. It may contain zero or +# more of `solo`, `lead`, `tail` and `middle` indicating that the generated the +# tail of a longer and in the middle of a longer string. If empty, it is treated +# as containing all four of the above. The CTRL field may also contain the words +# knownBug or knownW3C which will cause the test generation for that vector to +# be skipped. +# +# utf-32 missing because they are automatically generated based on le/be +# versions. +set encInvalidBytes {}; # Reset the table + +# ascii - Any byte above 127 is invalid and is mapped +# to the same numeric code point except for the range +# 80-9F which is treated as cp1252. +# This tests the TableToUtfProc code path. +lappend encInvalidBytes {*}{ + ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} + ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} + ascii 80 strict {} 0 {} {Smallest invalid byte} + ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} + ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} + ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} + ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} + ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} + ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} + ascii 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} + ascii 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} + ascii 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} + ascii 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} + ascii 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} + ascii 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} + ascii 8D tcl8 \u008D -1 {knownBug} {map to cp1252} + ascii 8E tcl8 \u017D -1 {knownBug} {map to cp1252} + ascii 8F tcl8 \u008F -1 {knownBug} {map to cp1252} + ascii 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} + ascii 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} + ascii 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} + ascii 93 tcl8 \u201C -1 {knownBug} {map to cp1252} + ascii 94 tcl8 \u201D -1 {knownBug} {map to cp1252} + ascii 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} + ascii 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} + ascii 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} + ascii 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} + ascii 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} + ascii 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} + ascii 9B tcl8 \u203A -1 {knownBug} {map to cp1252} + ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} + ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} + ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} + ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} + + ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} + ascii FF replace \uFFFD -1 {} {Largest invalid byte} + ascii FF strict {} 0 {} {Largest invalid byte} +} + +# utf-8 - valid sequences based on Table 3.7 in the Unicode +# standard. +# +# Code Points First Second Third Fourth Byte +# U+0000..U+007F 00..7F +# U+0080..U+07FF C2..DF 80..BF +# U+0800..U+0FFF E0 A0..BF 80..BF +# U+1000..U+CFFF E1..EC 80..BF 80..BF +# U+D000..U+D7FF ED 80..9F 80..BF +# U+E000..U+FFFF EE..EF 80..BF 80..BF +# U+10000..U+3FFFF F0 90..BF 80..BF 80..BF +# U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF +# U+100000..U+10FFFF F4 80..8F 80..BF 80..BF +# +# Tests below are based on the "gaps" in the above table. Note ascii test +# values are repeated because internally a different code path is used +# (UtfToUtfProc). +# Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 +lappend encInvalidBytes {*}{ + utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} + utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} + utf-8 80 strict {} 0 {} {Smallest invalid byte} + utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} + utf-8 82 tcl8 \u201A -1 {} {map to cp1252} + utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} + utf-8 84 tcl8 \u201E -1 {} {map to cp1252} + utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} + utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} + utf-8 87 tcl8 \u2021 -1 {} {map to cp1252} + utf-8 88 tcl8 \u02C6 -1 {} {map to cp1252} + utf-8 89 tcl8 \u2030 -1 {} {map to cp1252} + utf-8 8A tcl8 \u0160 -1 {} {map to cp1252} + utf-8 8B tcl8 \u2039 -1 {} {map to cp1252} + utf-8 8C tcl8 \u0152 -1 {} {map to cp1252} + utf-8 8D tcl8 \u008D -1 {} {map to cp1252} + utf-8 8E tcl8 \u017D -1 {} {map to cp1252} + utf-8 8F tcl8 \u008F -1 {} {map to cp1252} + utf-8 90 tcl8 \u0090 -1 {} {map to cp1252} + utf-8 91 tcl8 \u2018 -1 {} {map to cp1252} + utf-8 92 tcl8 \u2019 -1 {} {map to cp1252} + utf-8 93 tcl8 \u201C -1 {} {map to cp1252} + utf-8 94 tcl8 \u201D -1 {} {map to cp1252} + utf-8 95 tcl8 \u2022 -1 {} {map to cp1252} + utf-8 96 tcl8 \u2013 -1 {} {map to cp1252} + utf-8 97 tcl8 \u2014 -1 {} {map to cp1252} + utf-8 98 tcl8 \u02DC -1 {} {map to cp1252} + utf-8 99 tcl8 \u2122 -1 {} {map to cp1252} + utf-8 9A tcl8 \u0161 -1 {} {map to cp1252} + utf-8 9B tcl8 \u203A -1 {} {map to cp1252} + utf-8 9C tcl8 \u0153 -1 {} {map to cp1252} + utf-8 9D tcl8 \u009D -1 {} {map to cp1252} + utf-8 9E tcl8 \u017E -1 {} {map to cp1252} + utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} + + utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} + utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} + utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} + utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} + utf-8 C080 strict {} 0 {} {C080 -> invalid} + utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} + utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} + utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} + utf-8 C0A2 strict {} 0 {} {websec.github.io - A} + utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} + utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} + utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} + utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} + utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} + utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} + utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} + utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} + utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} + + utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} + utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} + utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} + utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} + utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} + utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} + utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} + + utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} + utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} + utf-8 C2 strict {} 0 {} {Missing trail byte} + utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} + utf-8 DF replace \uFFFD -1 {} {Missing trail byte} + utf-8 DF strict {} 0 {} {Missing trail byte} + utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} + + utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} + utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E0 strict {} 0 {} {Missing trail byte} + utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} + utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} + utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} + utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} + utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0A0 strict {} 0 {} {Missing second trail byte} + utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} + utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0BF strict {} 0 {} {Missing second trail byte} + utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte} + utf-8 E1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E1 strict {} 0 {} {Missing trail byte} + utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte} + utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E181 strict {} 0 {} {Missing second trail byte} + utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} + utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E1BF strict {} 0 {} {Missing second trail byte} + utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte} + utf-8 EC replace \uFFFD -1 {} {Missing trail byte} + utf-8 EC strict {} 0 {} {Missing trail byte} + utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte} + utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EC81 strict {} 0 {} {Missing second trail byte} + utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} + utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ECBF strict {} 0 {} {Missing second trail byte} + utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} + utf-8 ED replace \uFFFD -1 {} {Missing trail byte} + utf-8 ED strict {} 0 {} {Missing trail byte} + utf-8 ED7F tcl8 \u00ED\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} + utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} + utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} + utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ED81 strict {} 0 {} {Missing second trail byte} + utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} + utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EDBF strict {} 0 {} {Missing second trail byte} + utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} + utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} + utf-8 EDA080 strict {} 0 {} {High surrogate} + utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} + utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} + utf-8 EDAFBF strict {} 0 {} {High surrogate} + utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} + utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} + utf-8 EDB080 strict {} 0 {} {Low surrogate} + utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} + utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} + utf-8 EDBFBF strict {} 0 {} {Low surrogate} + utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} + + utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} + utf-8 EE replace \uFFFD -1 {} {Missing trail byte} + utf-8 EE strict {} 0 {} {Missing trail byte} + utf-8 EE7F tcl8 \u00EE\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} + utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EE81 strict {} 0 {} {Missing second trail byte} + utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} + utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EEBF strict {} 0 {} {Missing second trail byte} + utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} + utf-8 EF replace \uFFFD -1 {} {Missing trail byte} + utf-8 EF strict {} 0 {} {Missing trail byte} + utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} + utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EF81 strict {} 0 {} {Missing second trail byte} + utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} + utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EFBF strict {} 0 {} {Missing second trail byte} + utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} + utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F0 strict {} 0 {} {Missing trail byte} + utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF} + utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} + utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF} + utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} + utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} + utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F090 strict {} 0 {} {Missing second trail byte} + utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} + utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F0BF strict {} 0 {} {Missing second trail byte} + utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte} + utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F090BF strict {} 0 {} {Missing third trail byte} + utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} + utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F1 strict {} 0 {} {Missing trail byte} + utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF} + utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte} + utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F180 strict {} 0 {} {Missing second trail byte} + utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} + utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F1BF strict {} 0 {} {Missing second trail byte} + utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte} + utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F180BF strict {} 0 {} {Missing third trail byte} + utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} + utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F3 strict {} 0 {} {Missing trail byte} + utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF} + utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte} + utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F380 strict {} 0 {} {Missing second trail byte} + utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} + utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F3BF strict {} 0 {} {Missing second trail byte} + utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte} + utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F380BF strict {} 0 {} {Missing third trail byte} + utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} + utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F4 strict {} 0 {} {Missing trail byte} + utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F} + utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} + utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F} + utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} + utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte} + utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F480 strict {} 0 {} {Missing second trail byte} + utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} + utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F48F strict {} 0 {} {Missing second trail byte} + utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte} + utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48081 strict {} 0 {} {Missing third trail byte} + utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} + utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48F81 strict {} 0 {} {Missing third trail byte} + utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} + utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} + utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} + utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} + + utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} + utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9} + utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} + utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} +} + +# utf16-le and utf16-be test cases. Note utf16 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 strict {} 0 {solo tail} {Truncated} + utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} + utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} + + utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 strict {} 0 {solo tail} {Truncated} + utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate} + utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate} +} + +# utf32-le and utf32-be test cases. Note utf32 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-32le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 41 replace \uFFFD -1 {solo} {Truncated} + utf-32le 41 strict {} 0 {solo tail} {Truncated} + utf-32le 4100 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 4100 replace \uFFFD -1 {solo} {Truncated} + utf-32le 4100 strict {} 0 {solo tail} {Truncated} + utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} + utf-32le 410000 strict {} 0 {solo tail} {Truncated} + utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} + utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} + utf-32le 00D80000 strict {} 0 {} {High-surrogate} + utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate} + utf-32le 00DC0000 strict {} 0 {} {Low-surrogate} + utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair} + utf-32le 00001100 tcl8 \uFFFD -1 {} {Out of range} + utf-32le 00001100 replace \uFFFD -1 {} {Out of range} + utf-32le 00001100 strict {} 0 {} {Out of range} + utf-32le FFFFFFFF tcl8 \uFFFD -1 {} {Out of range} + utf-32le FFFFFFFF replace \uFFFD -1 {} {Out of range} + utf-32le FFFFFFFF strict {} 0 {} {Out of range} + + utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 strict {} 0 {solo tail} {Truncated} + utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 0041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 0041 strict {} 0 {solo tail} {Truncated} + utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 000041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 000041 strict {} 0 {solo tail} {Truncated} + utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} + utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} + utf-32be 0000D800 strict {} 0 {} {High-surrogate} + utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate} + utf-32be 0000DC00 strict {} 0 {} {Low-surrogate} + utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair} + utf-32be 00110000 tcl8 \uFFFD -1 {} {Out of range} + utf-32be 00110000 replace \uFFFD -1 {} {Out of range} + utf-32be 00110000 strict {} 0 {} {Out of range} + utf-32be FFFFFFFF tcl8 \uFFFD -1 {} {Out of range} + utf-32be FFFFFFFF replace \uFFFD -1 {} {Out of range} + utf-32be FFFFFFFF strict {} 0 {} {Out of range} +} + +# Strings that cannot be encoded for specific encoding / profiles +# <ENCODING STRING PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT> +# <ENCODING,STRING,PROFILE> should be unique for test ids to be unique. +# See earlier comments about CTRL field. +# +# Note utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +# TODO - out of range code point (note cannot be generated by \U notation) +lappend encUnencodableStrings {*}{ + ascii \u00e0 tcl8 3f -1 {} {unencodable} + ascii \u00e0 strict {} 0 {} {unencodable} + + iso8859-1 \u0141 tcl8 3f -1 {} unencodable + iso8859-1 \u0141 strict {} 0 {} unencodable + + utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate + utf-8 \uD800 strict {} 0 {} High-surrogate + utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate + utf-8 \uDC00 strict {} 0 {} High-surrogate +} + + +# The icuUcmTests.tcl is generated by the tools/ucm2tests.tcl script +# and generates test vectors for the above tables for various encodings +# based on ICU UCM files. +# TODO - commented out for now as generating a lot of mismatches. +# source [file join [file dirname [info script]] icuUcmTests.tcl] diff --git a/tests/env.test b/tests/env.test index fb0674d..5317897 100644 --- a/tests/env.test +++ b/tests/env.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-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. diff --git a/tests/error.test b/tests/error.test index 7f7b534..5bed039 100644 --- a/tests/error.test +++ b/tests/error.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-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. diff --git a/tests/eval.test b/tests/eval.test index 959dc87..9b8eccd 100644 --- a/tests/eval.test +++ b/tests/eval.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-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. diff --git a/tests/event.test b/tests/event.test index 50d1088..d62d08e 100644 --- a/tests/event.test +++ b/tests/event.test @@ -3,21 +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. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} +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] } @@ -511,12 +509,9 @@ test event-10.1 {Tcl_Exit procedure} {stdio} { [lindex $::errorCode 2] } {1 {child process exited abnormally} CHILDSTATUS 3} -test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body { +test event-11.1 {Tcl_VwaitCmd procedure} -body { vwait -} -result {wrong # args: should be "vwait name"} -test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body { - vwait a b -} -result {wrong # args: should be "vwait name"} +} -result {} test event-11.3 {Tcl_VwaitCmd procedure} -setup { catch {unset x} } -body { diff --git a/tests/exec.test b/tests/exec.test index e77a0ac..4058ae9 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. @@ -163,19 +163,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. diff --git a/tests/execute.test b/tests/execute.test index 4b0f87f..8702de6 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -8,8 +8,8 @@ # 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. @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} @@ -34,7 +34,7 @@ testConstraint testobj [expr { && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] @@ -179,7 +179,7 @@ test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x + 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} @@ -204,7 +204,7 @@ test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 + $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_SUB is partially tested: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { @@ -231,7 +231,7 @@ test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x - 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} @@ -256,7 +256,7 @@ test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 - $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_MULT is partially tested: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { @@ -283,7 +283,7 @@ test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x * 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} @@ -308,7 +308,7 @@ test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 * $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} # INST_DIV is partially tested: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { @@ -335,7 +335,7 @@ test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x / 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} @@ -360,7 +360,7 @@ test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 / $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} # INST_UPLUS is partially tested: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { @@ -387,7 +387,7 @@ test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {+ $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_UMINUS is partially tested: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { @@ -414,7 +414,7 @@ test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testob test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {- $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_LNOT is partially tested: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { @@ -462,7 +462,7 @@ test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "foo" as operand of "!"}} # INST_BITNOT not tested # INST_CALL_BUILTIN_FUNC1 not tested @@ -810,9 +810,9 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} { set y [expr {$x+1}] expr {double($x) == double($y)} } 1 -test execute-7.8 {Wide int conversions can change sign} longIs32bit { - set x 0x80000000 - expr {int($x) < wide($x)} +test execute-7.8 {Wide int conversions can change sign} { + set x 0x8000000000000000 + expr {wide($x) < 0} } 1 test execute-7.9 {Wide int handling in INST_MOD} { expr {(wide(1)<<60) % ((wide(47)<<45)-1)} @@ -892,12 +892,12 @@ test execute-7.31 {Wide int handling in abs()} { set y 0x123456871234568 concat [expr {abs($x)}] [expr {abs($y)}] } {730503879441204585 81985533099853160} -test execute-7.32 {Wide int handling} longIs32bit { +test execute-7.32 {Wide int handling} { expr {int(1024 * 1024 * 1024 * 1024)} -} 0 -test execute-7.33 {Wide int handling} longIs32bit { +} 1099511627776 +test execute-7.33 {Wide int handling} { expr {int(0x1 * 1024 * 1024 * 1024 * 1024)} -} 0 +} 1099511627776 test execute-7.34 {Wide int handling} { expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} } 1099511627776 @@ -985,7 +985,7 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup interp create child child eval { package require tcltest 2.5 - catch [list package require -exact Tcltest [info patchlevel]] + 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 } @@ -1018,7 +1018,7 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti interp create child child eval { package require tcltest 2.5 - catch [list package require -exact Tcltest [info patchlevel]] + 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 } @@ -1066,7 +1066,7 @@ 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 child diff --git a/tests/expr-old.test b/tests/expr-old.test index 6f85748..2401bd4 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -6,29 +6,26 @@ # "compExpr.test". Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -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]] testConstraint testexprstring [llength [info commands testexprstring]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] - -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -38,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) @@ -50,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) @@ -72,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 @@ -197,34 +194,34 @@ test expr-old-2.38 {floating-point operators} { test expr-old-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-old-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "4.0" as operand of "%"}} test expr-old-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "27.0" as operand of "%"}} test expr-old-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-old-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "3.0" as operand of ">>"}} test expr-old-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "3.0" as operand of "&"}} test expr-old-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value as operand of "|"}} +} {1 {can't use floating-point value "24.0" as operand of "|"}} test expr-old-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} # Check the string operators individually. @@ -265,46 +262,46 @@ test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "a" as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-old-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "a" as operand of "*"}} test expr-old-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "%"}} +} {1 {can't use non-numeric string "a" as operand of "%"}} test expr-old-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-old-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of ">>"}} +} {1 {can't use non-numeric string "a" as operand of ">>"}} test expr-old-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-old-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-old-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "|"}} +} {1 {can't use non-numeric string "a" as operand of "|"}} test expr-old-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -493,7 +490,7 @@ test expr-old-25.20 {type conversions} {expr 10.0} 10.0 test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * @@ -507,10 +504,10 @@ test expr-old-26.4 {error conditions} { set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.7 {error conditions} -body { expr {2+(4} } -returnCodes error -match glob -result * @@ -527,14 +524,14 @@ 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 } -returnCodes error -match glob -result * test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-26.14 {error conditions} -body { expr 2:3 } -returnCodes error -match glob -result * @@ -819,10 +816,10 @@ test expr-old-32.32 {math functions in expressions} { } {-1} test expr-old-32.33 {math functions in expressions} { expr int(1e60) -} 0 +} 999999999999999949387135297074018866963645011013410073083904 test expr-old-32.34 {math functions in expressions} { expr int(-1e60) -} 0 +} -999999999999999949387135297074018866963645011013410073083904 test expr-old-32.35 {math functions in expressions} { expr round(1.49) } {1} @@ -847,12 +844,6 @@ test expr-old-32.41 {math functions in expressions} { test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} -test expr-old-32.43 {math functions in expressions} testmathfunctions { - expr 2*T1() -} 246 -test expr-old-32.44 {math functions in expressions} testmathfunctions { - expr T2()*3 -} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} @@ -952,10 +943,6 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 -test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ - -body { - list [catch {expr T1(4)} msg] $msg - } -match glob -result {1 {too many arguments for math function*}} test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 @@ -963,7 +950,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} -body { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use invalid octal number "0o289" as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -1003,11 +990,11 @@ test expr-old-36.11 {ExprLooksLikeInt procedure} { test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "10;" as operand of "+"}} test expr-old-36.13 {ExprLooksLikeInt procedure} { set x " +" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string " +" as operand of "+"}} test expr-old-36.14 {ExprLooksLikeInt procedure} { set x "123456789012345678901234567890 " expr {$x+1} @@ -1015,7 +1002,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} { test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use invalid octal number "0o99 " as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} @@ -1052,8 +1039,8 @@ test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -0x80000000 } {This is a result: -2147483648} test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -0xffffffff -} {This is a result: 1} + testexprlong -0x7fffffff +} {This is a result: -2147483647} test expr-old-37.10 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ @@ -1077,9 +1064,13 @@ test expr-old-37.13 {Tcl_ExprLong handles overflows} \ test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -2147483648. } {This is a result: -2147483648} -test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -4294967295. -} {This is a result: 1} +test expr-old-37.15 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong -2147483649.} result] $result + } \ + -result {1 {integer value too large to represent*}} test expr-old-37.16 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ @@ -1159,8 +1150,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {not enough arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {not enough arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1161,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1175,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {not enough arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {not enough arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1186,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: diff --git a/tests/expr.test b/tests/expr.test index 2a0c7ed..2c1dc21 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -4,8 +4,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) 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. @@ -16,19 +16,14 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testmathfunctions [expr { - ([catch {expr {T1()}} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) -}] +catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] # Big test for correct ordering of data in [expr] @@ -38,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) @@ -50,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) @@ -74,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 @@ -143,9 +138,9 @@ proc do_twelve_days {} { catch {unset a b i x} -test expr-1.1 {TclCompileExprCmd: no expression} { - list [catch {expr } msg] $msg -} {1 {wrong # args: should be "expr arg ?arg ...?"}} +test expr-1.1 {TclCompileExprCmd: no expression} -body { + expr +} -returnCodes error -result {wrong # args: should be "expr arg ?arg ...?"} test expr-1.2 {TclCompileExprCmd: one expression word} { expr -25 } -25 @@ -192,12 +187,12 @@ test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in } foo test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} { set a xxx - set x 2; set b {$x}; set a [expr $b == 2] + set x 2; set b {$x}; set a [expr $b==2] set a } 1 test expr-1.15 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} { set a xxx - set x 2; set b {$x}; set a [expr $b eq 2] + set x 2; set b {$x}; set a [expr "$b eq 2"] set a } 1 @@ -257,7 +252,7 @@ test expr-4.9 {CompileLorExpr: long lor arm} { } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -304,10 +299,10 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -328,10 +323,10 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { @@ -356,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 @@ -416,17 +411,34 @@ test expr-8.34 {expr edge cases} -body { test expr-8.35 {expr edge cases} -body { expr {1ea} } -returnCodes error -match glob -result * +test expr-8.36 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x < $y}] [expr {$x lt $y}] [expr {$x lt $x}] +} {0 1 0} +test expr-8.37 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x <= $y}] [expr {$x le $y}] [expr {$x le $x}] +} {0 1 1} +test expr-8.38 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x > $y}] [expr {$x gt $y}] [expr {$x gt $x}] +} {1 0 0} +test expr-8.39 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x >= $y}] [expr {$x ge $y}] [expr {$x ge $x}] +} {1 0 1} test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 -test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { expr {int(1<<63)} -} -9223372036854775808 -test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 } -returnCodes error -match glob -result * @@ -456,10 +468,10 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -478,10 +490,10 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -509,10 +521,10 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { } -returnCodes error -match glob -result * test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -529,10 +541,10 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test expr-13.13 {CompileUnaryExpr: just primary expr} { set a 27 @@ -685,41 +697,6 @@ test expr-15.5 {CompileMathFuncCall: not enough arguments} -body { test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr 2*T1() -} 246 -test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T2()*3 -} 1035 -test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21, 37) -} 37 -test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21.2, 37) -} 37.0 -test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(-21.2, -17.5) -} -17.5 -test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21, wide(37)) -} 37 -test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37) -} 37 -test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), wide(37)) -} 37 -test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21.0, wide(37)) -} 37.0 -test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37.0) -} 37.0 -test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { - testmathfunctions -} -body { - expr T3(0,"a") -} -returnCodes error -result {argument to math function didn't have numeric value} test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { @@ -752,7 +729,7 @@ test expr-18.1 {expr and conversion of operands to numbers} { catch {expr int($x)} expr {$x} } 11 -test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} { +test expr-18.2 {whitespace strings should not be == 0 (buggy strtol/strtoul)} { expr {" "} } { } @@ -802,7 +779,7 @@ test expr-20.2 {double invocation of variable traces} -body { set var "$counter + [concat $extraargs]" } } - trace variable exprtracevar r [list exprtraceproc 10] + trace add variable exprtracevar read [list exprtraceproc 10] list [catch {expr "$exprtracevar + 20"} a] $a \ [catch {expr "$exprtracevar + 20"} b] $b \ [unset exprtracevar exprtracecounter] @@ -844,15 +821,15 @@ test expr-21.13 {non-numeric boolean literals} -body { } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "true " as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err @@ -872,23 +849,23 @@ test expr-21.20 {non-numeric boolean variables} { test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "o" as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use empty string as operand of "!"}} +} {1 {can't use empty string "" as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg @@ -901,7 +878,7 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "/"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}} test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} @@ -937,10 +914,10 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { } -returnCodes error -match glob -result * test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "xx" as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "a" as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { list [catch {expr {0**-1}} msg] $msg } {1 {exponentiation of zero by negative power}} @@ -1444,14 +1421,15 @@ test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 -test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5<<32)} 0 -test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5<<63)} 0 +test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480 +test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 test expr-24.10 {INST_LSHIFT: Bug 1567222} {expr 500000000000000<<28} 134217728000000000000000 test expr-24.11 {INST_LSHIFT: Bug 84a5355235} {expr -549755813888>>32} -128 +test expr-24.12 {INST_LSHIFT: Bug 920e393634} {expr 7244019458077122840<<1} 14488038916154245680 # List membership tests test expr-25.1 {'in' operator} {expr {"a" in "a b c"}} 1 @@ -5849,7 +5827,7 @@ test expr-32.9 {bignum regression} { expr {0%-(1+(1<<63))} } 0 -test expr-33.1 {parse largest long value} longIs32bit { +test expr-33.1 {parse largest long value} { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " @@ -5863,7 +5841,7 @@ test expr-33.1 {parse largest long value} longIs32bit { [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) < 0}] \ + [expr {int(2147483647 + 1) > 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { @@ -5883,7 +5861,7 @@ test expr-33.2 {parse smallest long value} longIs32bit { [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ + [expr {int(-2147483648 - 1) == -0x80000001}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { @@ -5963,17 +5941,17 @@ test expr-34.11 {expr edge cases} { test expr-34.12 {expr edge cases} { expr {$min % -2} } {0} -test expr-34.13 {expr edge cases} longIs32bit { +test expr-34.13 {expr edge cases} { expr {int($min / -1)} -} {-2147483648} +} {2147483648} test expr-34.14 {expr edge cases} { expr {$min % -1} } {0} -test expr-34.15 {expr edge cases} longIs32bit { - expr {int($min * -1)} +test expr-34.15 {expr edge cases} { + expr {-int($min * -1)} } $min -test expr-34.16 {expr edge cases} longIs32bit { - expr {int(-$min)} +test expr-34.16 {expr edge cases} { + expr {-int(-$min)} } $min test expr-34.17 {expr edge cases} { expr {$min / 1} @@ -6766,8 +6744,8 @@ test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -0x80000000 } {This is a result: -2147483648} test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -0xffffffff -} {This is a result: 1} + testexprlongobj -0x7fffffff +} {This is a result: -2147483647} test expr-39.10 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -6792,8 +6770,8 @@ test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -2147483648. } {This is a result: -2147483648} test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -4294967295. -} {This is a result: 1} + testexprlongobj -2147483648. +} {This is a result: -2147483648} test expr-39.16 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -7278,6 +7256,204 @@ test expr-52.1 { ::tcl::unsupported::representation $a]] } {0 0 1 1} +foreach func {isfinite isinf isnan isnormal issubnormal} { + test expr-53.1.$func {float classification: basic arg handling} -body { + expr ${func}() + } -returnCodes error -result "not enough arguments for math function \"$func\"" + test expr-53.2.$func {float classification: basic arg handling} -body { + expr ${func}(1,2) + } -returnCodes error -result "too many arguments for math function \"$func\"" + test expr-53.3.$func {float classification: basic arg handling} -body { + expr ${func}(true) + } -returnCodes error -result {expected number but got "true"} + test expr-53.4.$func {float classification: basic arg handling} -body { + expr ${func}("gorp") + } -returnCodes error -result {expected number but got "gorp"} + test expr-53.5.$func {float classification: basic arg handling} -body { + expr ${func}(1.0) + } -match glob -result * + test expr-53.6.$func {float classification: basic arg handling} -body { + expr ${func}(0x123) + } -match glob -result * +} + +test expr-54.0 {float classification: isfinite} {expr {isfinite(1.0)}} 1 +test expr-54.1 {float classification: isfinite} {expr {isfinite(-1.0)}} 1 +test expr-54.2 {float classification: isfinite} {expr {isfinite(0.0)}} 1 +test expr-54.3 {float classification: isfinite} {expr {isfinite(-0.0)}} 1 +test expr-54.4 {float classification: isfinite} {expr {isfinite(1/Inf)}} 1 +test expr-54.5 {float classification: isfinite} {expr {isfinite(-1/Inf)}} 1 +test expr-54.6 {float classification: isfinite} {expr {isfinite(1e-314)}} 1 +test expr-54.7 {float classification: isfinite} {expr {isfinite(inf)}} 0 +test expr-54.8 {float classification: isfinite} {expr {isfinite(-inf)}} 0 +test expr-54.9 {float classification: isfinite} {expr {isfinite(NaN)}} 0 + +test expr-55.0 {float classification: isinf} {expr {isinf(1.0)}} 0 +test expr-55.1 {float classification: isinf} {expr {isinf(-1.0)}} 0 +test expr-55.2 {float classification: isinf} {expr {isinf(0.0)}} 0 +test expr-55.3 {float classification: isinf} {expr {isinf(-0.0)}} 0 +test expr-55.4 {float classification: isinf} {expr {isinf(1/Inf)}} 0 +test expr-55.5 {float classification: isinf} {expr {isinf(-1/Inf)}} 0 +test expr-55.6 {float classification: isinf} {expr {isinf(1e-314)}} 0 +test expr-55.7 {float classification: isinf} {expr {isinf(inf)}} 1 +test expr-55.8 {float classification: isinf} {expr {isinf(-inf)}} 1 +test expr-55.9 {float classification: isinf} {expr {isinf(NaN)}} 0 + +test expr-56.0 {float classification: isnan} {expr {isnan(1.0)}} 0 +test expr-56.1 {float classification: isnan} {expr {isnan(-1.0)}} 0 +test expr-56.2 {float classification: isnan} {expr {isnan(0.0)}} 0 +test expr-56.3 {float classification: isnan} {expr {isnan(-0.0)}} 0 +test expr-56.4 {float classification: isnan} {expr {isnan(1/Inf)}} 0 +test expr-56.5 {float classification: isnan} {expr {isnan(-1/Inf)}} 0 +test expr-56.6 {float classification: isnan} {expr {isnan(1e-314)}} 0 +test expr-56.7 {float classification: isnan} {expr {isnan(inf)}} 0 +test expr-56.8 {float classification: isnan} {expr {isnan(-inf)}} 0 +test expr-56.9 {float classification: isnan} {expr {isnan(NaN)}} 1 + +test expr-57.0 {float classification: isnormal} {expr {isnormal(1.0)}} 1 +test expr-57.1 {float classification: isnormal} {expr {isnormal(-1.0)}} 1 +test expr-57.2 {float classification: isnormal} {expr {isnormal(0.0)}} 0 +test expr-57.3 {float classification: isnormal} {expr {isnormal(-0.0)}} 0 +test expr-57.4 {float classification: isnormal} {expr {isnormal(1/Inf)}} 0 +test expr-57.5 {float classification: isnormal} {expr {isnormal(-1/Inf)}} 0 +test expr-57.6 {float classification: isnormal} {expr {isnormal(1e-314)}} 0 +test expr-57.7 {float classification: isnormal} {expr {isnormal(inf)}} 0 +test expr-57.8 {float classification: isnormal} {expr {isnormal(-inf)}} 0 +test expr-57.9 {float classification: isnormal} {expr {isnormal(NaN)}} 0 + +test expr-58.0 {float classification: issubnormal} {expr {issubnormal(1.0)}} 0 +test expr-58.1 {float classification: issubnormal} {expr {issubnormal(-1.0)}} 0 +test expr-58.2 {float classification: issubnormal} {expr {issubnormal(0.0)}} 0 +test expr-58.3 {float classification: issubnormal} {expr {issubnormal(-0.0)}} 0 +test expr-58.4 {float classification: issubnormal} {expr {issubnormal(1/Inf)}} 0 +test expr-58.5 {float classification: issubnormal} {expr {issubnormal(-1/Inf)}} 0 +test expr-58.6 {float classification: issubnormal} {expr {issubnormal(1e-314)}} 1 +test expr-58.7 {float classification: issubnormal} {expr {issubnormal(inf)}} 0 +test expr-58.8 {float classification: issubnormal} {expr {issubnormal(-inf)}} 0 +test expr-58.9 {float classification: issubnormal} {expr {issubnormal(NaN)}} 0 + +test expr-59.0 {float classification: fpclassify} {fpclassify 1.0} normal +test expr-59.1 {float classification: fpclassify} {fpclassify -1.0} normal +test expr-59.2 {float classification: fpclassify} {fpclassify 0.0} zero +test expr-59.3 {float classification: fpclassify} {fpclassify -0.0} zero +test expr-59.4 {float classification: fpclassify} {fpclassify [expr 1/Inf]} zero +test expr-59.5 {float classification: fpclassify} {fpclassify [expr -1/Inf]} zero +test expr-59.6 {float classification: fpclassify} {fpclassify 1e-314} subnormal +test expr-59.7 {float classification: fpclassify} {fpclassify inf} infinite +test expr-59.8 {float classification: fpclassify} {fpclassify -inf} infinite +test expr-59.9 {float classification: fpclassify} {fpclassify NaN} nan +test expr-59.10 {float classification: fpclassify} -returnCodes error -body { + fpclassify +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.11 {float classification: fpclassify} -returnCodes error -body { + fpclassify a b +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.12 {float classification: fpclassify} -returnCodes error -body { + fpclassify gorp +} -result {expected number but got "gorp"} + +test expr-60.1 {float classification: basic arg handling} -body { + expr isunordered() +} -returnCodes error -result {not enough arguments for math function "isunordered"} +test expr-60.2 {float classification: basic arg handling} -body { + expr isunordered(1) +} -returnCodes error -result {not enough arguments for math function "isunordered"} +test expr-60.3 {float classification: basic arg handling} -body { + expr {isunordered(1, 2, 3)} +} -returnCodes error -result {too many arguments for math function "isunordered"} +test expr-60.4 {float classification: basic arg handling} -body { + expr {isunordered(true, 1.0)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.5 {float classification: basic arg handling} -body { + expr {isunordered("gorp", 1.0)} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.6 {float classification: basic arg handling} -body { + expr {isunordered(0x123, 1.0)} +} -match glob -result * +test expr-60.7 {float classification: basic arg handling} -body { + expr {isunordered(1.0, true)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.8 {float classification: basic arg handling} -body { + expr {isunordered(1.0, "gorp")} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.9 {float classification: basic arg handling} -body { + expr {isunordered(1.0, 0x123)} +} -match glob -result * + +# Big matrix of comparisons, but it's just a binary isinf() +set values {1.0 -1.0 0.0 -0.0 1e-314 Inf -Inf NaN} +set results {0 0 0 0 0 0 0 1} +set ctr 0 +foreach v1 $values r1 $results { + foreach v2 $values r2 $results { + test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" { + expr {isunordered($v1, $v2)} + } [expr {$r1 || $r2}] + } +} +unset -nocomplain values results ctr + +test expr-62.1 {TIP 582: comments} -body { + expr {1 # + 2} +} -result 1 +test expr-62.2 {TIP 582: comments} -body { + expr "1 #\n+ 2" +} -result 3 +test expr-62.3 {TIP 582: comments} -setup { + set ctr 0 +} -body { + expr { + # This is a demonstration of a comment + 1 + 2 + 3 + # and another comment + + 4 + 5 + # + [incr ctr] + + [incr ctr] + } +} -result 16 +# Buggy because line breaks aren't tracked inside expressions at all +test expr-62.4 {TIP 582: comments don't hide line breaks} -setup { + proc getline {} { + dict get [info frame -1] line + } + set base [getline] +} -constraints knownBug -body { + expr { + 0 + # a comment + + [getline] - $base + } +} -cleanup { + rename getline "" +} -result 5 +test expr-62.5 {TIP 582: comments don't splice tokens} { + set a False + expr {$a#don't splice +ne#don't splice +false} +} 1 +test expr-62.6 {TIP 582: comments don't splice tokens} { + expr {0x2#don't splice +ne#don't splice +2} +} 1 +test expr-62.7 {TIP 582: comments can go inside function calls} { + expr {max(1,# comment + 2)} +} 2 +test expr-62.8 {TIP 582: comments can go inside function calls} { + expr {max(1# comment + ,2)} +} 2 +test expr-62.9 {TIP 582: comments can go inside function calls} { + expr {max(# comment + 1,2)} +} 2 +test expr-62.10 {TIP 582: comments can go inside function calls} { + expr {max# comment + (1,2)} +} 2 + # Bug e3dcab1d14 proc do-one-test-expr-63 {e p float athreshold} { # e - power of 2 to test @@ -7315,14 +7491,12 @@ proc run-test-expr-63 {} { rename run-test-expr-63 {} } run-test-expr-63 - - + # cleanup -if {[info exists a]} { - unset a -} -catch {unset min} -catch {unset max} +unset -nocomplain a +unset -nocomplain min +unset -nocomplain max + ::tcltest::cleanupTests return diff --git a/tests/fCmd.test b/tests/fCmd.test index d711138..2469762 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1999 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. @@ -16,14 +16,12 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] -testConstraint winVista 0 -testConstraint win2000orXP 0 testConstraint winLessThan10 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 @@ -45,6 +43,8 @@ if {[testConstraint win]} { } } +testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}] + # File permissions broken on wsl without some "exotic" wsl configuration testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}] @@ -70,17 +70,8 @@ if {[testConstraint unix]} { } # Also used in winFCmd... -if {[testConstraint win] && [testConstraint nt]} { - if {$::tcl_platform(osVersion) >= 5.0} { - if {$::tcl_platform(osVersion) < 10.0} { - testConstraint winLessThan10 1 - } - if {$::tcl_platform(osVersion) >= 6.0} { - testConstraint winVista 1 - } else { - testConstraint win2000orXP 1 - } - } +if {[testConstraint win] && $::tcl_platform(osVersion) < 10.0} { + testConstraint winLessThan10 1 } testConstraint darwin9 [expr { @@ -112,6 +103,45 @@ if {[testConstraint unix]} { } } +# Try getting a lower case glob pattern that will match the home directory of +# a given user to test ~user and [file tildeexpand ~user]. Note this may not +# be the same as ~ even when "user" is current user. For example, on Unix +# platforms ~ will return HOME envvar, but ~user will lookup password file +# bypassing HOME. If home directory not found, returns *$user* so caller can +# succeed by using glob matching under the hope that the path contains +# the user name. +proc gethomedirglob {user} { + if {[testConstraint unix]} { + if {![catch { + exec {*}[auto_execok sh] -c "echo ~$user" + } home]} { + set home [string trim $home] + if {$home ne ""} { + # Expect exact match (except case), no glob * added + return [string tolower $home] + } + } + } elseif {[testConstraint reg]} { + # Windows with registry extension loaded + if {![catch { + set sid [exec {*}[auto_execok powershell] -Command "(Get-LocalUser -Name '$user')\[0\].sid.Value"] + set sid [string trim $sid] + # Get path from the Windows registry + set home [registry get "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\ProfileList\\$sid" ProfileImagePath] + set home [string trim [string tolower $home]] + } result]} { + if {$home ne ""} { + # file join for \ -> / + return [file join [string tolower $home]] + } + } + } + + # Caller will need to use glob matching and hope user + # name is in the home directory path + return *[string tolower $user]* +} + proc createfile {file {string a}} { set f [open $file w] puts -nonewline $f $string @@ -291,7 +321,7 @@ test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { } -constraints {notRoot unixOrWin} -returnCodes error -body { file mkdir td1 file rename / td1 -} -result {error renaming "/" to "td1": file already exists} +} -result {error renaming "/" to "td1": file exists} test fCmd-3.16 {FileCopyRename: break on first error} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -302,7 +332,7 @@ test fCmd-3.16 {FileCopyRename: break on first error} -setup { file mkdir td1 createfile [file join td1 tf3] file rename tf1 tf2 tf3 tf4 td1 -} -result [subst {error renaming "tf3" to "[file join td1 tf3]": file already exists}] +} -result [subst {error renaming "tf3" to "[file join td1 tf3]": file exists}] test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} -setup { cleanup @@ -358,7 +388,7 @@ test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} -setup { } -constraints {notRoot} -returnCodes error -body { createfile tf1 file mkdir tf1 -} -result [subst {can't create directory "[file join tf1]": file already exists}] +} -result [subst {can't create directory "[file join tf1]": file exists}] test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} -setup { cleanup } -constraints {notRoot} -body { @@ -428,7 +458,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 @@ -533,14 +563,14 @@ test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} -setup { createfile tf1 createfile tf2 file rename tf1 tf2 -} -result {error renaming "tf1" to "tf2": file already exists} +} -result {error renaming "tf1" to "tf2": file exists} test fCmd-6.11 {CopyRenameOneFile: force == 0} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { createfile tf1 createfile tf2 file rename tf1 tf2 -} -result {error renaming "tf1" to "tf2": file already exists} +} -result {error renaming "tf1" to "tf2": file exists} test fCmd-6.12 {CopyRenameOneFile: force != 0} -setup { cleanup } -constraints {notRoot} -body { @@ -575,7 +605,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 @@ -584,12 +614,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 @@ -633,7 +663,7 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {xdev notRoot notWsl} -body { file mkdir td1/td2/td3 - file attributes td1 -permissions 0o000 + file attributes td1 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { file attributes td1 -permissions 0o755 @@ -644,7 +674,7 @@ 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 0o000 + file attributes $td1name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 @@ -656,7 +686,7 @@ 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 0o000 + file attributes $td1name -permissions 0 file copy td2 ~/td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 @@ -667,7 +697,7 @@ 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 0o000 + file attributes $td2name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { file attributes $td2name -permissions 0o755 @@ -680,12 +710,12 @@ test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { file mkdir [file join $tmpspace td1] createfile [file join $tmpspace td1 tf1] file rename -force td1 $tmpspace -} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists} +} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file exists} test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev notWsl} -body { file mkdir td1/td2/td3 - file attributes td1/td2/td3 -permissions 0o000 + file attributes td1/td2/td3 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { file attributes td1/td2/td3 -permissions 0o755 @@ -799,18 +829,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 win2000orXP 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 notWsl} -body { file mkdir td1 td2 @@ -823,7 +842,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 @@ -831,17 +850,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 win2000orXP 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 notWsl} -body { file mkdir td1 @@ -853,7 +862,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 @@ -874,7 +883,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { file rename -force tfs3 tfd3 file rename -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] -} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} +} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file exists}} 1 1 0 0} test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { cleanup } -constraints {notRoot testchmod notNetworkFilesystem} -body { @@ -910,25 +919,18 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { } list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 -} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}] +} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file exists}} 1 1 0 0}] # 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}] @@ -950,16 +952,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}] @@ -974,18 +969,18 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { [catch {file rename td1 td2} msg] $msg } -cleanup { testchmod 0o755 [file join td2 td1] -} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] +} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file exists}}] # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] [file join td2 td1 td4] file rename -force td1 td2 } -returnCodes error -match glob -result \ [subst {error renaming "td1" to "[file join td2 td1]": file *}] test fCmd-9.14 {file rename: comprehensive: dir into self} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir td1 list [glob td*] [list [catch {file rename td1 td1} msg] $msg] } -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] @@ -1081,7 +1076,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 @@ -1111,7 +1106,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { file copy -force tfs3 tfd3 file copy -force tfs4 tfd4 list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] -} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} +} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file exists}} 1 1 0 0} test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { cleanup } -constraints {notRoot testchmod} -body { @@ -1135,7 +1130,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { set a4 [catch {file copy -force tds3 tdd3}] set a5 [catch {file copy -force tds4 tdd4}] list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 -} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] +} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { cleanup } -constraints {notRoot unixOrWin testchmod notWsl} -body { @@ -1147,7 +1142,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] -} -result [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}] +} -result [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file exists}} 1 0}] test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { cleanup } -constraints {notRoot testchmod} -body { @@ -1548,7 +1543,7 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot notWsl} -body { file mkdir tfa/dir/a/b/c - file attributes tfa/dir -permissions 0o000 + file attributes tfa/dir -permissions 0 catch {file copy tfa tfa2} } -cleanup { file attributes tfa/dir -permissions 0o777 @@ -1591,7 +1586,7 @@ test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup { } -constraints {unix notRoot} -body { file mkdir tfa createfile tfa/file - file attributes tfa -permissions 0o000 + file attributes tfa -permissions 0 catch {file mkdir tfa/file} } -cleanup { file attributes tfa -permissions 0o777 @@ -1960,7 +1955,7 @@ test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -se } -constraints {unix notRoot notWsl} -body { file mkdir tfa file mkdir tfa/a - file attributes tfa/a -permissions 0o000 + file attributes tfa/a -permissions 00000 catch {file delete -force tfa} } -cleanup { file attributes tfa/a -permissions 0o777 @@ -2366,7 +2361,7 @@ test fCmd-28.6 {file link: unsupported operation} -setup { file link -hard abc.link abc.dir } -returnCodes error -cleanup { cd [workingDirectory] -} -result {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory} +} -result {could not create new link "abc.link" pointing to "abc.dir": is a directory} test fCmd-28.7 {file link: source already exists} -setup { cd [temporaryDirectory] } -constraints {linkFile} -body { @@ -2425,7 +2420,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] @@ -2433,7 +2428,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 @@ -2459,7 +2454,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 { @@ -2493,7 +2488,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]] @@ -2514,7 +2509,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 { @@ -2524,13 +2519,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 { @@ -2541,7 +2536,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 { @@ -2599,16 +2594,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 # 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 notContinuousIntegration -} -body { +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 @@ -2618,6 +2611,146 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints { } return $r } -result {exists 1 readable 0 stat 0 {}} + +test fCmd-31.1 {file home} -body { + file home +} -result [file join $::env(HOME)] +test fCmd-31.2 {file home - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file home +} -result [file join $::env(HOME) xxx] +test fCmd-31.3 {file home - \ -> /} -constraints win -setup { + set saved $::env(HOME) + set ::env(HOME) C:\\backslash\\path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result C:/backslash/path +test fCmd-31.4 {file home - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-31.5 { + file home - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result relative/path +test fCmd-31.6 {file home USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + string tolower [file home $::tcl_platform(user)] +} -match glob -result [gethomedirglob $::tcl_platform(user)] +test fCmd-31.7 {file home UNKNOWNUSER} -body { + file home nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-31.8 {file home extra arg} -body { + file home $::tcl_platform(user) arg +} -returnCodes error -result {wrong # args: should be "file home ?user?"} +test fCmd-31.9 {file home USER does not follow env(HOME)} -setup { + set ::env(HOME) [file join $::env(HOME) foo] +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + string tolower [file home $::tcl_platform(user)] +} -match glob -result [gethomedirglob $::tcl_platform(user)] + +test fCmd-32.1 {file tildeexpand ~} -body { + file tildeexpand ~ +} -result [file join $::env(HOME)] +test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file tildeexpand ~ +} -result [file join $::env(HOME) xxx] +test fCmd-32.3 {file tildeexpand ~ - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-32.4 { + file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -result relative/path +test fCmd-32.5 {file tildeexpand ~USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + string tolower [file tildeexpand ~$::tcl_platform(user)] +} -match glob -result [gethomedirglob $::tcl_platform(user)] +test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.7 {file tildeexpand ~extra arg} -body { + file tildeexpand ~ arg +} -returnCodes error -result {wrong # args: should be "file tildeexpand path"} +test fCmd-32.8 {file tildeexpand ~/path} -body { + file tildeexpand ~/foo +} -result [file join $::env(HOME)/foo] +test fCmd-32.9 {file tildeexpand ~USER/bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + string tolower [file tildeexpand ~$::tcl_platform(user)/bar] +} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar] +test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser/foo +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.11 {file tildeexpand /~/path} -body { + file tildeexpand /~/foo +} -result /~/foo +test fCmd-32.12 {file tildeexpand /~user/path} -body { + file tildeexpand /~$::tcl_platform(user)/foo +} -result /~$::tcl_platform(user)/foo +test fCmd-32.13 {file tildeexpand ./~} -body { + file tildeexpand ./~ +} -result ./~ +test fCmd-32.14 {file tildeexpand relative/path} -body { + file tildeexpand relative/path +} -result relative/path +test fCmd-32.15 {file tildeexpand ~\\path} -body { + file tildeexpand ~\\foo +} -constraints win -result [file join $::env(HOME)/foo] +test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + string tolower [file tildeexpand ~$::tcl_platform(user)\\bar] +} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar] +test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup { + set ::env(HOME) [file join $::env(HOME) foo] +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + string tolower [file tildeexpand ~$::tcl_platform(user)] +} -match glob -result [gethomedirglob $::tcl_platform(user)] + # cleanup cleanup diff --git a/tests/fileName.test b/tests/fileName.test index 2a35987..b147bd7 100644 --- a/tests/fileName.test +++ b/tests/fileName.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) 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. @@ -15,8 +15,10 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] @@ -30,6 +32,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. @@ -199,7 +202,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo -} "/ foo" +} "//foo" test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar @@ -436,14 +439,14 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b -} "/a/b" +} "//a/b" test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b } "/a/b" test filename-7.19 {[Bug f34cf83dd0]} { file join foo //bar -} /bar +} //bar test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win @@ -788,7 +791,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 +802,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 +815,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 +830,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 +848,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 +880,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 +897,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 +906,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 +936,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 +953,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 +970,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 +979,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]\ @@ -1230,10 +1233,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} { @@ -1242,7 +1245,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 { @@ -1282,7 +1285,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]\ @@ -1327,7 +1330,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 0o000} +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}}} @@ -1627,6 +1630,61 @@ test fileName-20.10 {globbing for special chars} -setup { removeFile fileName-20.10 $s removeDirectory sub ~ } -result ~/sub/fileName-20.10 + + +apply [list {} { + test fileName-6d4e9d1af5bf5b7d { + memory leak in SetFsPathFromAny + + Runs under both a TCL_DEBUG_MEM build and a -DPURIFY build for + valgrind, which is useful since Valgrind provides information about the + error location, but [memory] doesn't. + } -setup { + if {[namespace which ::memory] eq {}} { + set memcheckcmd [list ::apply [list script { + uplevel 1 $script + return 0 + } [namespace current]]] + } else { + set memcheckcmd ::tcltests::scriptmemcheck + } + } -body { + {*}$memcheckcmd { + set interp [interp create] + interp eval $interp { + apply [list {} { + upvar 1 f f + + # A unique name so that no internal representation of this + # literal value has been picked up from any other script + # that has alredy been sourced into this interpreter. + set variableUniqueInTheEntireTclCodebase a + set name variableUniqueInTheEntireTclCodebase + + # give the Tcl_Obj for "var1" an internal representation of + # type 'localVarNameType'. + set $name + + set f [open variableUniqueInTheEntireTclCodebase w] + try { + puts $f {some data} + } finally { + close $f + } + + set f [open variableUniqueInTheEntireTclCodebase] + try { + read $f + } finally { + catch {file delete variableUniqueInTheEntireTclCodebase} + close $f + } + } [namespace current]] + } + interp delete $interp + } + } -result 0 +} [namespace current]] # cleanup catch {file delete -force C:/globTest} diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 1e6045b..d62a59a 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -4,18 +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. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - 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 @@ -26,15 +25,15 @@ 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]] @@ -390,13 +389,13 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { testPathEqual [file norm /../../] [file norm /] } ok -test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body { - set x //foo +test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -body { + set x ///foo file normalize $x file join $x bar } -result /foo/bar test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { - set x //foo + set x ///foo file normalize $x file join $x } -result /foo @@ -693,7 +692,7 @@ test filesystem-7.4 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file exists} 0 {} 1} test filesystem-7.5 {cross-filesystem file copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -705,7 +704,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 0o000 + file attributes file2 -permissions 0 # Second copy should fail (no -force) lappend res [catch {file copy simplefs:/simplefile file2} err] lappend res $err @@ -718,7 +717,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file exists} 0 {} 1} test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -746,7 +745,7 @@ test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { file delete -force simpledir file delete -force dir2 cd $dir -} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} +} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file exists} 0 {} 1 1} test filesystem-7.7 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -776,7 +775,7 @@ test filesystem-7.7 {cross-filesystem dir copy with -force} -setup { file delete -force simpledir file delete -force dir2 cd $dir -} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} +} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file exists} 0 {} 1 1} removeFile gorp.file test filesystem-7.8 {vfs cd} -setup { set dir [pwd] diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 24003b8..f47635d 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh -# Copyright (c) 2019 Poor Yorick +# Copyright © 2019 Poor Yorick if {[string equal $::tcl_platform(os) "Windows NT"]} { return @@ -13,7 +13,7 @@ namespace eval ::tcl::test::fileSystemEncoding { namespace import -force ::tcltest::* } - variable fname1 \u767b\u9e1b\u9d72\u6a13 + variable fname1 登鸛鵲樓 source [file join [file dirname [info script]] tcltests.tcl] diff --git a/tests/for-old.test b/tests/for-old.test index baf40fa..f5d1de9 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -6,8 +6,8 @@ # 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. diff --git a/tests/for.test b/tests/for.test index 8659d8e..26300ce 100644 --- a/tests/for.test +++ b/tests/for.test @@ -4,7 +4,7 @@ # 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. diff --git a/tests/foreach.test b/tests/foreach.test index bb06b80..4a1c35a 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -4,8 +4,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) 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. diff --git a/tests/format.test b/tests/format.test index 43100bc..c5053e8 100644 --- a/tests/format.test +++ b/tests/format.test @@ -4,8 +4,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) 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. @@ -16,23 +16,21 @@ if {"::tcltest" ni [namespace children]} { } # %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit [expr { - (wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain # particularly in Continuous Integration, and there isn't anything much we can # do about it. -testConstraint notWinCI [expr { - ($::tcl_platform(platform) ne "windows") || ![info exists ::env(CI)]}] - +testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] + test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 -} { 6 34 16923 -12 -1 0xe 0XC} +} { 6 34 16923 -12 -1 0xe 0xC} test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} @@ -58,49 +56,40 @@ test format-1.7.1 {integer formatting} longIs64bit { } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0X22 0X421B 0xfffffff4} +} {0 0x6 0x22 0x421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4} +} {0 0x6 0x22 0x421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0x0 0x6 0x22 0x421b 0xfffffff4} +} { 0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4} +} { 0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0x22 0x421b 0xfffffff4 } +} {0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 } +} {0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 06 042 041033 037777777764 } +} {0 0o6 0o42 0o41033 0o37777777764 } test format-1.11.1 {integer formatting} longIs64bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 06 042 041033 01777777777777777777764} +} {0 0o6 0o42 0o41033 0o1777777777777777777764} test format-1.12 {integer formatting} { format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] -} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} -test format-1.13 {integer formatting} longIs32bit { - format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12} -test format-1.13.1 {integer formatting} longIs64bit { - format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12} -test format-1.14 {integer formatting} longIs32bit { - format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 -} { 0 6 34 16923 -12} -test format-1.14.1 {integer formatting} longIs64bit { - format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 -} { 0 6 34 16923 -12} -test format-1.15 {integer formatting} longIs32bit { - format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12 } -test format-1.15.1 {integer formatting} longIs64bit { - format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12 } +} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} +test format-1.13 {integer formatting} { + format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 +} {0 0d6 0d34 0d16923 -0d12} +test format-1.14 {integer formatting} { + format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} +test format-1.15 {integer formatting} { + format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} test format-2.1 {string formatting} { @@ -116,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" @@ -154,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 @@ -278,13 +273,13 @@ test format-6.1 {floating-point zeroes} {eformat} { test format-6.2 {floating-point zeroes} {eformat} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} -test format-6.3 {floating-point zeroes} {eformat notWinCI} { +test format-6.3 {floating-point zeroes} {eformat knownMsvcBug} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} test format-6.4 {floating-point zeroes} {eformat} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} -test format-6.5 {floating-point zeroes} {eformat notWinCI} { +test format-6.5 {floating-point zeroes} {eformat knownMsvcBug} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} test format-6.6 {floating-point zeroes} { @@ -373,9 +368,9 @@ test format-8.19 {error conditions} { catch {format %q x} } 1 test format-8.20 {error conditions} { - catch {format %q x} msg + catch {format %r x} msg set msg -} {bad field specifier "q"} +} {bad field specifier "r"} test format-8.21 {error conditions} { catch {format %d} } 1 @@ -387,6 +382,26 @@ test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} +# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and +# equivalent to "%d" in 32-bit platforms, they are really not useful in +# scripts, therefore they are not documented. It's intended use is through +# the function Tcl_AppendPrintfToObj (et al). +test format-8.24 {Undocumented formats} -body { + format "%zd %td %d" [expr {2**30}] [expr {2**30}] [expr {2**30}] +} -result {1073741824 1073741824 1073741824} +test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { + format "%zd %td %lld" [expr {2**33}] [expr {2**33}] [expr {2**33}] +} -result {8589934592 8589934592 8589934592} +# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent +# to "%#x" in 32-bit platforms, it are really not useful in scripts, +# therefore they are not documented. It's intended use is through the +# function Tcl_AppendPrintfToObj (et al). +test format-8.26 {Undocumented formats} -body { + format "%p %#x" [expr {2**31}] [expr {2**31}] +} -result {0x80000000 0x80000000} +test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { + format "%p %#llx" [expr {2**33}] [expr {2**33}] +} -result {0x200000000 0x200000000} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -540,7 +555,7 @@ for {set i 290} {$i < 400} {incr i} { append b "x" } -test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { +test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} {wideIs64bit} { @@ -554,7 +569,7 @@ test format-17.4 {testing %l with non-integer} { } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef -} -returnCodes 1 -result {unsigned bignum format is invalid} +} -result 207698809136909011942886895 test format-17.6 {testing %llu with negative number} -body { format %llu -1 } -returnCodes 1 -result {unsigned bignum format is invalid} @@ -573,7 +588,7 @@ test format-18.1 {do not demote existing numeric values} { format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} -test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { +test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] diff --git a/tests/get.test b/tests/get.test index a7bab5d..079166e 100644 --- a/tests/get.test +++ b/tests/get.test @@ -4,8 +4,8 @@ # 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. @@ -16,10 +16,11 @@ if {"::tcltest" ni [namespace children]} { } ::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]] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} @@ -42,12 +43,12 @@ test get-1.6 {Tcl_GetInt procedure} testgetint { test get-1.7 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.8 {Tcl_GetInt procedure} testgetint { - list [catch {testgetint 18446744073709551614} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} -test get-1.9 {Tcl_GetInt procedure} testgetint { - list [catch {testgetint +18446744073709551614} msg] $msg $errorCode -} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { + testgetint 18446744073709551614 +} {-2} +test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { + testgetint +18446744073709551614 +} {-2} test get-1.10 {Tcl_GetInt procedure} testgetint { list [catch {testgetint -18446744073709551614} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} @@ -62,7 +63,7 @@ test get-1.13 {Tcl_GetInt procedure} testgetint { } {0 -2} test get-1.14 {Tcl_GetInt procedure} testgetint { list [catch {testgetint -4294967294} msg] $msg -} {0 2} +} {1 {integer value too large to represent}} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 @@ -96,17 +97,23 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 52 52 46} +} {44 44 44 44 54 51 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {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 813f84f..557c856 100644 --- a/tests/history.test +++ b/tests/history.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-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. diff --git a/tests/http.test b/tests/http.test index 498621b..e9a0b31 100644 --- a/tests/http.test +++ b/tests/http.test @@ -4,9 +4,9 @@ # 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. @@ -15,23 +15,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] -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 child interp"} - set interp [interp create http2] - $interp eval [list set http2 "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - return - } -} -testConstraint http2.9.7 [package vsatisfies [package provide http] 2.9.7] -testConstraint http2.9.8 [package vsatisfies [package provide http] 2.9.8] +package require http 2.10 proc bgerror {args} { global errorInfo @@ -44,8 +30,7 @@ proc bgerror {args} { # 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 port 8010 -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +set bindata "This is binary data\x0D\x0Amore\x0Dmore\x0Amore\x00null" catch {unset data} # Ensure httpd file exists @@ -62,10 +47,10 @@ if {![file exists $httpdFile]} { catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] + lappend threadStack [list thread::release $httpthread] thread::send $httpthread [list source $httpdFile] - thread::send $httpthread [list set port $port] thread::send $httpthread [list set bindata $bindata] - thread::send $httpthread {httpd_init $port} + thread::send $httpthread {httpd_init 0; set port} port puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { @@ -77,26 +62,46 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { # Let the OS pick the port; that's much more flexible if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} return + } + set threadStack {} +} + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} } else { - # Running httpd in the current thread overwrites the values of port - # (here) and HOST (in the sourced server file). - set port [lindex [fconfigure $listen -sockname] 2] + set ValueRange {0 1} } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + if {[llength $threadStack]} { + eval [lpop threadStack] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return } + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel -test http-1.1 {http::config} { +test http-1.1.$ThreadLevel {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] -test http-1.2 {http::config} { +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter http::ProxyRequired -proxyhost {} -proxynot {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1] +test http-1.2.$ThreadLevel {http::config} { http::config -proxyfilter } http::ProxyRequired -test http-1.3 {http::config} { +test http-1.3.$ThreadLevel {http::config} { catch {http::config -junk} } 1 -test http-1.4 {http::config} { +test http-1.4.$ThreadLevel {http::config} { set savedconf [http::config] http::config -proxyhost nowhere.come -proxyport 8080 \ -proxyfilter myFilter -useragent "Tcl Test Suite" \ @@ -104,11 +109,11 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} -test http-1.5 {http::config} -returnCodes error -body { +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter myFilter -proxyhost nowhere.come -proxynot {} -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1] +test http-1.5.$ThreadLevel {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} -test http-1.6 {http::config} -setup { +} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyauth, -proxyfilter, -proxyhost, -proxynot, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip} +test http-1.6.$ThreadLevel {http::config} -setup { set oldenc [http::config -urlencoding] } -body { set enc [list [http::config -urlencoding]] @@ -118,40 +123,42 @@ test http-1.6 {http::config} -setup { http::config -urlencoding $oldenc } -result {utf-8 iso8859-1} -test http-2.1 {http::reset} { +test http-2.1.$ThreadLevel {http::reset} { catch {http::reset http#1} } 0 -test http-2.2 {http::CharsetToEncoding} http2.9.7 { +test http-2.2.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-8859-11 } iso8859-11 -test http-2.3 {http::CharsetToEncoding} http2.9.7 { +test http-2.3.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-2022-kr } iso2022-kr -test http-2.4 {http::CharsetToEncoding} http2.9.7 { +test http-2.4.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding shift-jis } shiftjis -test http-2.5 {http::CharsetToEncoding} http2.9.7 { +test http-2.5.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding windows-437 } cp437 -test http-2.6 {http::CharsetToEncoding} http2.9.7 { +test http-2.6.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin5 } iso8859-9 -test http-2.7 {http::CharsetToEncoding} http2.9.7 { +test http-2.7.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin1 } iso8859-1 -test http-2.8 {http::CharsetToEncoding} http2.9.7 { +test http-2.8.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin4 } binary -test http-3.1 {http::geturl} -returnCodes error -body { +test http-3.1.$ThreadLevel {http::geturl} -returnCodes error -body { http::geturl -bogus flag -} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} -test http-3.2 {http::geturl} -returnCodes error -body { +} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -guesstype, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} + +test http-3.2.$ThreadLevel {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} + set url //${::HOST}:$port set badurl //${::HOST}:[expr {$port+1}] -test http-3.3 {http::geturl} -body { +test http-3.3.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { @@ -160,6 +167,7 @@ test http-3.3 {http::geturl} -body { <h1>Hello, World!</h1> <h2>GET /</h2> </body></html>" + set tail /a/b/c set url //${::HOST}:$port/a/b/c set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c @@ -169,7 +177,8 @@ set posturl //${::HOST}:$port/post set badposturl //${::HOST}:$port/droppost set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ -test http-3.4 {http::geturl} -body { + +test http-3.4.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { @@ -182,7 +191,7 @@ proc selfproxy {host} { global port return [list ${::HOST} $port] } -test http-3.5 {http::geturl} -body { +test http-3.5.$ThreadLevel {http::geturl} -body { http::config -proxyfilter selfproxy set token [http::geturl $url] http::data $token @@ -193,7 +202,7 @@ test http-3.5 {http::geturl} -body { <h1>Hello, World!</h1> <h2>GET http:$url</h2> </body></html>" -test http-3.6 {http::geturl} -body { +test http-3.6.$ThreadLevel {http::geturl} -body { http::config -proxyfilter bogus set token [http::geturl $url] http::data $token @@ -204,7 +213,7 @@ test http-3.6 {http::geturl} -body { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" -test http-3.7 {http::geturl} -body { +test http-3.7.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -headers {Pragma no-cache}] http::data $token } -cleanup { @@ -213,7 +222,7 @@ test http-3.7 {http::geturl} -body { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" -test http-3.8 {http::geturl} -body { +test http-3.8.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000] http::data $token } -cleanup { @@ -227,13 +236,13 @@ test http-3.8 {http::geturl} -body { <dt>Foo<dd>Bar </dl> </body></html>" -test http-3.9 {http::geturl} -body { +test http-3.9.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -validate 1] http::code $token } -cleanup { http::cleanup $token } -result "HTTP/1.0 200 OK" -test http-3.10 {http::geturl queryprogress} -setup { +test http-3.10.$ThreadLevel {http::geturl queryprogress} -setup { set query foo=bar set sep "" set i 0 @@ -256,7 +265,7 @@ test http-3.10 {http::geturl queryprogress} -setup { } -cleanup { http::cleanup $t } -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}} -test http-3.11 {http::geturl querychannel with -command} -setup { +test http-3.11.$ThreadLevel {http::geturl querychannel with -command} -setup { set query foo=bar set sep "" set i 0 @@ -295,7 +304,7 @@ test http-3.11 {http::geturl querychannel with -command} -setup { # The status is "eof". # On Windows, the http::wait procedure gets a "connection reset by peer" error # while reading the reply. -test http-3.12 {http::geturl querychannel with aborted request} -setup { +test http-3.12.$ThreadLevel {http::geturl querychannel with aborted request} -setup { set query foo=bar set sep "" set i 0 @@ -333,7 +342,7 @@ test http-3.12 {http::geturl querychannel with aborted request} -setup { removeFile outdata http::cleanup $t } -result {ok {HTTP/1.0 200 Data follows}} -test http-3.13 {http::geturl socket leak test} { +test http-3.13.$ThreadLevel {http::geturl socket leak test} { set chanCount [llength [file channels]] for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} @@ -341,43 +350,43 @@ test http-3.13 {http::geturl socket leak test} { # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 -test http-3.14 "http::geturl $fullurl" -body { +test http-3.14.$ThreadLevel "http::geturl $fullurl" -body { set token [http::geturl $fullurl -validate 1] http::code $token } -cleanup { http::cleanup $token } -result "HTTP/1.0 200 OK" -test http-3.15 {http::geturl parse failures} -body { +test http-3.15.$ThreadLevel {http::geturl parse failures} -body { http::geturl "{invalid}:url" } -returnCodes error -result {Unsupported URL: {invalid}:url} -test http-3.16 {http::geturl parse failures} -body { +test http-3.16.$ThreadLevel {http::geturl parse failures} -body { http::geturl http:relative/url } -returnCodes error -result {Unsupported URL: http:relative/url} -test http-3.17 {http::geturl parse failures} -body { +test http-3.17.$ThreadLevel {http::geturl parse failures} -body { http::geturl /absolute/url } -returnCodes error -result {Missing host part: /absolute/url} -test http-3.18 {http::geturl parse failures} -body { +test http-3.18.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere:123456789/ } -returnCodes error -result {Invalid port number: 123456789} -test http-3.19 {http::geturl parse failures} -body { +test http-3.19.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://{user}@somewhere } -returnCodes error -result {Illegal characters in URL user} -test http-3.20 {http::geturl parse failures} -body { +test http-3.20.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://%user@somewhere } -returnCodes error -result {Illegal encoding character usage "%us" in URL user} -test http-3.21 {http::geturl parse failures} -body { +test http-3.21.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/{path} } -returnCodes error -result {Illegal characters in URL path} -test http-3.22 {http::geturl parse failures} -body { +test http-3.22.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/%path } -returnCodes error -result {Illegal encoding character usage "%pa" in URL path} -test http-3.23 {http::geturl parse failures} -body { +test http-3.23.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/path?{query}? } -returnCodes error -result {Illegal characters in URL path} -test http-3.24 {http::geturl parse failures} -body { +test http-3.24.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/path?%query } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path} -test http-3.25 {http::meta} -setup { +test http-3.25.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -timeout 3000] @@ -386,8 +395,8 @@ test http-3.25 {http::meta} -setup { } -cleanup { http::cleanup $token unset -nocomplain m token -} -result {Content-Length Content-Type Date} -test http-3.26 {http::meta} -setup { +} -result {content-length content-type date} +test http-3.26.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -headers {X-Check 1} -timeout 3000] @@ -396,8 +405,8 @@ test http-3.26 {http::meta} -setup { } -cleanup { http::cleanup $token unset -nocomplain m token -} -result {Content-Length Content-Type Date X-Check} -test http-3.27 {http::geturl: -headers override -type} -body { +} -result {content-length content-type date x-check} +test http-3.27.$ThreadLevel {http::geturl: -headers override -type} -body { set token [http::geturl $url/headers -type "text/plain" -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token @@ -405,12 +414,12 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} -test http-3.28 {http::geturl: -headers override -type default} -body { +test http-3.28.$ThreadLevel {http::geturl: -headers override -type default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token @@ -418,12 +427,12 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} -test http-3.29 {http::geturl IPv6 address} -body { +test http-3.29.$ThreadLevel {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is # the case if http::geturl succeeds or returns a socket related # error. If the parsing is wrong, we'll get a parse error. @@ -437,20 +446,20 @@ test http-3.29 {http::geturl IPv6 address} -body { } -cleanup { catch { http::cleanup $token } } -result 0 -test http-3.30 {http::geturl query without path} -body { +test http-3.30.$ThreadLevel {http::geturl query without path} -body { set token [http::geturl $authorityurl?var=val] http::ncode $token } -cleanup { catch { http::cleanup $token } } -result 200 -test http-3.31 {http::geturl fragment without path} -body { +test http-3.31.$ThreadLevel {http::geturl fragment without path} -body { set token [http::geturl "$authorityurl#fragment42"] http::ncode $token } -cleanup { catch { http::cleanup $token } } -result 200 # Bug c11a51c482 -test http-3.32 {http::geturl: -headers override -accept default} -body { +test http-3.32.$ThreadLevel {http::geturl: -headers override -accept default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Accept" "text/plain,application/tcl-test-value"]] http::data $token @@ -458,50 +467,48 @@ test http-3.32 {http::geturl: -headers override -accept default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Accept text/plain,application/tcl-test-value Accept-Encoding .* +Connection close Content-Type application/x-www-form-urlencoded Content-Length 5} # Bug 838e99a76d -test http-3.33 {http::geturl application/xml is text} -body { +test http-3.33.$ThreadLevel {http::geturl application/xml is text} -body { set token [http::geturl "$xmlurl"] scan [http::data $token] "<%\[^>]>%c<%\[^>]>" } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} - - -test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { +test http-3.34.$ThreadLevel {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" -} -constraints http2.9.8 -result {Bad value for -headers ("), must be list} -test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { +} -result {Bad value for -headers ("), must be list} +test http-3.35.$ThreadLevel {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} -} -constraints http2.9.8 -result {Bad value for -headers (List Length 3), number of list elements must be even} +} -result {Bad value for -headers (List Length 3), number of list elements must be even} -test http-4.1 {http::Event} -body { +test http-4.1.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) - expr {($data(totalsize) == $meta(Content-Length))} + expr {($data(totalsize) == $meta(content-length))} } -cleanup { http::cleanup $token } -result 1 -test http-4.2 {http::Event} -body { +test http-4.2.$ThreadLevel {http::Event} -body { set token [http::geturl $url] upvar #0 $token data array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] + string compare $data(type) [string trim $meta(content-type)] } -cleanup { http::cleanup $token } -result 0 -test http-4.3 {http::Event} -body { +test http-4.3.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::code $token } -cleanup { http::cleanup $token } -result {HTTP/1.0 200 Data follows} -test http-4.4 {http::Event} -setup { +test http-4.4.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -518,7 +525,7 @@ test http-4.4 {http::Event} -setup { <h1>Hello, World!</h1> <h2>GET $tail</h2> </body></html>" -test http-4.5 {http::Event} -setup { +test http-4.5.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -531,7 +538,7 @@ test http-4.5 {http::Event} -setup { removeFile $testfile http::cleanup $token } -result 1 -test http-4.6 {http::Event} -setup { +test http-4.6.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -553,64 +560,68 @@ proc myProgress {token total current} { } set progress [list $total $current] } -test http-4.6.1 {http::Event} knownBug { +test http-4.6.1.$ThreadLevel {http::Event} knownBug { set token [http::geturl $url -blocksize 50 -progress myProgress] return $progress } {111 111} -test http-4.7 {http::Event} -body { +test http-4.7.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress } -cleanup { http::cleanup $token } -result {111 111} -test http-4.8 {http::Event} -body { +test http-4.8.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::status $token } -cleanup { http::cleanup $token } -result {ok} -test http-4.9 {http::Event} -body { +test http-4.9.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::code $token } -cleanup { http::cleanup $token } -result {HTTP/1.0 200 Data follows} -test http-4.10 {http::Event} -body { +test http-4.10.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::size $token } -cleanup { http::cleanup $token } -result {111} + # Timeout cases # Short timeout to working server (the test server). This lets us try a # reset during the connection. -test http-4.11 {http::Event} -body { +test http-4.11.$ThreadLevel {http::Event} -body { set token [http::geturl $url -timeout 1 -keepalive 0 -command \#] http::reset $token http::status $token } -cleanup { http::cleanup $token } -result {reset} + # Longer timeout with reset. -test http-4.12 {http::Event} -body { +test http-4.12.$ThreadLevel {http::Event} -body { set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#] http::reset $token http::status $token } -cleanup { http::cleanup $token } -result {reset} + # Medium timeout to working server that waits even longer. The timeout # hits while waiting for a reply. -test http-4.13 {http::Event} -body { +test http-4.13.$ThreadLevel {http::Event} -body { set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#] http::wait $token http::status $token } -cleanup { http::cleanup $token } -result {timeout} + # Longer timeout to good host, bad port, gets an error after the # connection "completes" but the socket is bad. -test http-4.14 {http::Event} -body { +test http-4.14.$ThreadLevel {http::Event} -body { set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] if {$token eq ""} { error "bogus return from http::geturl" @@ -619,19 +630,24 @@ test http-4.14 {http::Event} -body { lindex [http::error $token] 0 } -cleanup { catch {http::cleanup $token} -} -result {connect failed connection refused} +} -result {connect failed: connection refused} + # Bogus host -test http-4.15 {http::Event} -body { +test http-4.15.$ThreadLevel {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. - set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#] + # With http::config -threadlevel 1 or 2, the script enters the event loop + # during the DNS lookup, and has the opportunity to time out. + # Increase -timeout from 3000 to 10000 to prevent this. + set token [http::geturl //not_a_host.tcl.tk -timeout 10000 -command \#] http::wait $token - http::status $token + set result "[http::status $token] -- [lindex [http::error $token] 0]" # error codes vary among platforms. } -cleanup { catch {http::cleanup $token} -} -returnCodes 1 -match glob -result "couldn't open socket*" -test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { +} -match glob -result "error -- couldn't open socket*" + +test http-4.16.$ThreadLevel {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { proc list-difference {l1 l2} { lmap item $l2 {if {$item in $l1} continue; set item} } @@ -646,25 +662,25 @@ test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { rename list-difference {} } -result {} -test http-5.1 {http::formatQuery} { +test http-5.1.$ThreadLevel {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" } {name1=value1&name2=value%20two} # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5 -test http-5.3 {http::formatQuery} { +test http-5.3.$ThreadLevel {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 +test http-5.4.$ThreadLevel {http::formatQuery} { + http::formatQuery name1 ~bwelch name2 ¡¢¢ } {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2} -test http-5.5 {http::formatQuery} { +test http-5.5.$ThreadLevel {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} -test http-6.1 {http::ProxyRequired} -body { +test http-6.1.$ThreadLevel {http::ProxyRequired} -body { http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token @@ -678,41 +694,487 @@ test http-6.1 {http::ProxyRequired} -body { <h2>GET http:$url</h2> </body></html>" -test http-7.1 {http::mapReply} { +test http-7.1.$ThreadLevel {http::mapReply} { http::mapReply "abc\$\[\]\"\\()\}\{" } {abc%24%5B%5D%22%5C%28%29%7D%7B} -test http-7.2 {http::mapReply} { +test http-7.2.$ThreadLevel {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 { +test http-7.3.$ThreadLevel {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { - # this would be reverting to http <=2.4 behavior + # -urlencoding "" no longer supported. Use "iso8859-1". http::config -urlencoding "" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result "can't read \"formMap(\u2208)\": no such element in array" -test http-7.4 {http::formatQuery} -setup { +} -result {unknown encoding ""} +test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors - # (unknown chars become '?') + # with Tcl 8.x (unknown chars become '?'), generating a + # proper exception with Tcl 9.0 http::config -urlencoding "iso8859-1" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc } -result {%3F} +package require tcl::idna 1.0 + +test http-idna-1.1.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna +} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} +test http-idna-1.2.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna ? +} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} +test http-idna-1.3.$ThreadLevel {IDNA package: basics} -body { + ::tcl::idna version +} -result 1.0.1 +test http-idna-1.4.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna version what +} -result {wrong # args: should be "::tcl::idna version"} +test http-idna-1.5.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny +} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} +test http-idna-1.6.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny ? +} -result {unknown or ambiguous subcommand "?": must be decode, or encode} +test http-idna-1.7.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.8.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode a b c +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.9.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.10.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode a b c +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.11.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna decode +} -result {wrong # args: should be "::tcl::idna decode hostname"} +test http-idna-1.12.$ThreadLevel {IDNA package: basics} -returnCodes error -body { + ::tcl::idna encode +} -result {wrong # args: should be "::tcl::idna encode hostname"} + +test http-idna-2.1.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode abc +} abc- +test http-idna-2.2.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode a€b€c +} abc-k50ab +test http-idna-2.3.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode ABC +} ABC- +test http-idna-2.4.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode A€B€C +} ABC-k50ab +test http-idna-2.5.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode ABC 0 +} abc- +test http-idna-2.6.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode A€B€C 0 +} abc-k50ab +test http-idna-2.7.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode ABC 1 +} ABC- +test http-idna-2.8.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode A€B€C 1 +} ABC-k50ab +test http-idna-2.9.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode abc 0 +} abc- +test http-idna-2.10.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode a€b€c 0 +} abc-k50ab +test http-idna-2.11.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode abc 1 +} ABC- +test http-idna-2.12.$ThreadLevel {puny encode: functional test} { + ::tcl::idna puny encode a€b€c 1 +} ABC-k50ab +test http-idna-2.13.$ThreadLevel {puny encode: edge cases} { + ::tcl::idna puny encode "" +} "" +test http-idna-2.14-A.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F + }]] ""] +} egbpdaj6bu4bxfgehfvwxn +test http-idna-2.14-B.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 + }]] ""] +} ihqwcrb4cv8a8dqg056pqjye +test http-idna-2.14-C.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 + }]] ""] +} ihqwctvzc91f659drss3x8bo0yb +test http-idna-2.14-D.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 + }]] ""] +} Proprostnemluvesky-uyb24dma41a +test http-idna-2.14-E.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA + }]] ""] +} 4dbcagdahymbxekheh6e0a7fei0b +test http-idna-2.14-F.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 + }]] ""] +} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd +test http-idna-2.14-G.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B + }]] ""] +} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa +test http-idna-2.14-H.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C + }]] ""] +} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c +test http-idna-2.14-I.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 + }]] ""] +} b1abfaaepdrnnbgefbadotcwatmq2g4l +test http-idna-2.14-J.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C + }]] ""] +} PorqunopuedensimplementehablarenEspaol-fmd56a +test http-idna-2.14-K.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 + }]] ""] +} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g +test http-idna-2.14-L.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F + }]] ""] +} 3B-ww4c5e180e575a65lsy2b +test http-idna-2.14-M.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 + }]] ""] +} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n +test http-idna-2.14-N.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 + }]] ""] +} Hello-Another-Way--fc4qua05auwb3674vfr0b +test http-idna-2.14-O.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 + }]] ""] +} 2-u9tlzr9756bt3uc0v +test http-idna-2.14-P.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D + }]] ""] +} MajiKoi5-783gue6qz075azm5e +test http-idna-2.14-Q.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 + }]] ""] +} de-jg4avhby1noc0d +test http-idna-2.14-R.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 + }]] ""] +} d9juau41awczczp +test http-idna-2.14-S.$ThreadLevel {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode {-> $1.00 <-} +} {-> $1.00 <--} + +test http-idna-3.1.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc- +} abc +test http-idna-3.2.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab +} a€b€c +test http-idna-3.3.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC- +} ABC +test http-idna-3.4.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC-k50ab +} A€B€C +test http-idna-3.5.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB +} A€B€C +test http-idna-3.6.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc-K50AB +} a€b€c +test http-idna-3.7.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC- 0 +} abc +test http-idna-3.8.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 0 +} a€b€c +test http-idna-3.9.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC- 1 +} ABC +test http-idna-3.10.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 1 +} A€B€C +test http-idna-3.11.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc- 0 +} abc +test http-idna-3.12.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 0 +} a€b€c +test http-idna-3.13.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc- 1 +} ABC +test http-idna-3.14.$ThreadLevel {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 1 +} A€B€C +test http-idna-3.15.$ThreadLevel {puny decode: edge cases and errors} { + # Is this case actually correct? + binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] +} c282c281c280 +test http-idna-3.16.$ThreadLevel {puny decode: edge cases and errors} -returnCodes error -body { + ::tcl::idna puny decode abc! +} -result {bad decode character "!"} +test http-idna-3.17.$ThreadLevel {puny decode: edge cases and errors} { + catch {::tcl::idna puny decode abc!} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-3.18.$ThreadLevel {puny decode: edge cases and errors} { + ::tcl::idna puny decode "" +} {} +# A helper so we don't get lots of crap in failures +proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} +test http-idna-3.19-A.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] +} [list {*}{ + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F +}] +test http-idna-3.19-B.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] +} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} +test http-idna-3.19-C.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] +} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} +test http-idna-3.19-D.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] +} [list {*}{ + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 +}] +test http-idna-3.19-E.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] +} [list {*}{ + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA +}] +test http-idna-3.19-F.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] +} [list {*}{ + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 +}] +test http-idna-3.19-G.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] +} [list {*}{ + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B +}] +test http-idna-3.19-H.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] +} [list {*}{ + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}] +test http-idna-3.19-I.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] +} [list {*}{ + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 +}] +test http-idna-3.19-J.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + PorqunopuedensimplementehablarenEspaol-fmd56a] +} [list {*}{ + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C +}] +test http-idna-3.19-K.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] +} [list {*}{ + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 +}] +test http-idna-3.19-L.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] +} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} +test http-idna-3.19-M.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] +} [list {*}{ + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 +}] +test http-idna-3.19-N.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] +} [list {*}{ + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 +}] +test http-idna-3.19-O.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] +} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} +test http-idna-3.19-P.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] +} [list {*}{ + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D +}] +test http-idna-3.19-Q.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode de-jg4avhby1noc0d] +} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} +test http-idna-3.19-R.$ThreadLevel {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode d9juau41awczczp] +} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} +test http-idna-3.19-S.$ThreadLevel {puny decode: examples from RFC 3492} { + ::tcl::idna puny decode {-> $1.00 <--} +} {-> $1.00 <-} +rename hexify "" + +test http-idna-4.1.$ThreadLevel {IDNA encoding} { + ::tcl::idna encode abc.def +} abc.def +test http-idna-4.2.$ThreadLevel {IDNA encoding} { + ::tcl::idna encode a€b€c.def +} xn--abc-k50ab.def +test http-idna-4.3.$ThreadLevel {IDNA encoding} { + ::tcl::idna encode def.a€b€c +} def.xn--abc-k50ab +test http-idna-4.4.$ThreadLevel {IDNA encoding} { + ::tcl::idna encode ABC.DEF +} ABC.DEF +test http-idna-4.5.$ThreadLevel {IDNA encoding} { + ::tcl::idna encode A€B€C.def +} xn--ABC-k50ab.def +test http-idna-4.6.$ThreadLevel {IDNA encoding: invalid edge case} { + # Should this be an error? + ::tcl::idna encode abc..def +} abc..def +test http-idna-4.7.$ThreadLevel {IDNA encoding: invalid char} -returnCodes error -body { + ::tcl::idna encode abc.$.def +} -result {bad character "$" in DNS name} +test http-idna-4.7.1.$ThreadLevel {IDNA encoding: invalid char} { + catch {::tcl::idna encode abc.$.def} -> opt + dict get $opt -errorcode +} {IDNA INVALID_NAME_CHARACTER {$}} +test http-idna-4.8.$ThreadLevel {IDNA encoding: empty} { + ::tcl::idna encode "" +} {} +set overlong www.[join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}]] ""].com +test http-idna-4.9.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} -body { + ::tcl::idna encode $overlong +} -returnCodes error -result "hostname part too long" +test http-idna-4.9.1.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} { + catch {::tcl::idna encode $overlong} -> opt + dict get $opt -errorcode +} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} +unset overlong +test http-idna-4.10.$ThreadLevel {IDNA encoding: edge cases} { + ::tcl::idna encode passé.example.com +} xn--pass-epa.example.com + +test http-idna-5.1.$ThreadLevel {IDNA decoding} { + ::tcl::idna decode abc.def +} abc.def +test http-idna-5.2.$ThreadLevel {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.def +} abc.def +test http-idna-5.3.$ThreadLevel {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.xn--def- +} abc.def +test http-idna-5.4.$ThreadLevel {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode XN--abc-.XN--def- +} abc.def +test http-idna-5.5.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--$$$.example.com +} -result {bad decode character "$"} +test http-idna-5.5.1.$ThreadLevel {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--$$$.example.com} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-5.6.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def +} -result {exceeded input data} +test http-idna-5.6.1.$ThreadLevel {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT LENGTH} + # cleanup catch {unset url} catch {unset badurl} catch {unset port} catch {unset data} -if {[info exists httpthread]} { - thread::release $httpthread +if {[llength $threadStack]} { + eval [lpop threadStack] } else { close $listen } diff --git a/tests/http11.test b/tests/http11.test index f243e56..55e7d39 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -2,7 +2,7 @@ # # Test HTTP/1.1 features. # -# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> +# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require http 2.9 +package require http 2.10 # start the server variable httpd_output @@ -51,15 +51,11 @@ proc halt_httpd {} { } proc meta {tok {key ""}} { - set meta [http::meta $tok] - if {$key ne ""} { - if {[dict exists $meta $key]} { - return [dict get $meta $key] - } else { - return "" - } + if {$key eq ""} { + return [http::meta $tok] + } else { + return [http::metaValue $tok $key] } - return $meta } proc state {tok {key ""}} { @@ -87,10 +83,32 @@ proc check_crc {tok args} { } makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html + +makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 5000]\n</body></html>" largedoc.html + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel # ------------------------------------------------------------------------- -test http11-1.0 "normal request for document " -setup { +test http11-1.0.$ThreadLevel "normal request for document " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000] @@ -101,20 +119,21 @@ test http11-1.0 "normal request for document " -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close} -test http11-1.1 "normal,gzip,non-chunked" -setup { +test http11-1.1.$ThreadLevel "normal,gzip,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ -timeout 10000 -headers {accept-encoding gzip}] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ - [meta $tok content-encoding] [meta $tok transfer-encoding] + [meta $tok content-encoding] [meta $tok transfer-encoding] \ + [http::meta $tok content-encoding] [http::meta $tok transfer-encoding] } -cleanup { http::cleanup $tok halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok gzip {}} +} -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}} -test http11-1.2 "normal,deflated,non-chunked" -setup { +test http11-1.2.$ThreadLevel "normal,deflated,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -127,7 +146,22 @@ test http11-1.2 "normal,deflated,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} -test http11-1.3 "normal,compressed,non-chunked" -setup { +test http11-1.2.1.$ThreadLevel "normal,deflated,non-chunked,msdeflate" -setup { + variable httpd [create_httpd] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ + -timeout 10000 -headers {accept-encoding deflate}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok content-encoding] [meta $tok transfer-encoding] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok deflate {}} + +test http11-1.3.$ThreadLevel "normal,compressed,non-chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -140,7 +174,7 @@ test http11-1.3 "normal,compressed,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress {}} -test http11-1.4 "normal,identity,non-chunked" -setup { +test http11-1.4.$ThreadLevel "normal,identity,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -153,7 +187,7 @@ test http11-1.4 "normal,identity,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {}} -test http11-1.5 "normal request for document, unsupported coding" -setup { +test http11-1.5.$ThreadLevel "normal request for document, unsupported coding" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -166,20 +200,21 @@ test http11-1.5 "normal request for document, unsupported coding" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {}} -test http11-1.6 "normal, specify 1.1 " -setup { +test http11-1.6.$ThreadLevel "normal, specify 1.1 " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ -protocol 1.1 -timeout 10000] http::wait $tok list [http::status $tok] [http::code $tok] [check_crc $tok] \ - [meta $tok connection] [meta $tok transfer-encoding] + [meta $tok connection] [meta $tok transfer-encoding] \ + [http::meta $tok connection] [http::meta $tok transfer-encoding] } -cleanup { http::cleanup $tok halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok close chunked} +} -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}} -test http11-1.7 "normal, 1.1 and keepalive " -setup { +test http11-1.7.$ThreadLevel "normal, 1.1 and keepalive " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -192,7 +227,7 @@ test http11-1.7 "normal, 1.1 and keepalive " -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} -test http11-1.8 "normal, 1.1 and keepalive, server close" -setup { +test http11-1.8.$ThreadLevel "normal, 1.1 and keepalive, server close" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -205,7 +240,7 @@ test http11-1.8 "normal, 1.1 and keepalive, server close" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {}} -test http11-1.9 "normal,gzip,chunked" -setup { +test http11-1.9.$ThreadLevel "normal,gzip,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -218,7 +253,7 @@ test http11-1.9 "normal,gzip,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok gzip chunked} -test http11-1.10 "normal,deflate,chunked" -setup { +test http11-1.10.$ThreadLevel "normal,deflate,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -231,7 +266,22 @@ test http11-1.10 "normal,deflate,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} -test http11-1.11 "normal,compress,chunked" -setup { +test http11-1.10.1.$ThreadLevel "normal,deflate,chunked,msdeflate" -setup { + variable httpd [create_httpd] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 10000 -headers {accept-encoding deflate}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok content-encoding] [meta $tok transfer-encoding] +} -cleanup { + http::cleanup $tok + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok deflate chunked} + +test http11-1.11.$ThreadLevel "normal,compress,chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -244,7 +294,7 @@ test http11-1.11 "normal,compress,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress chunked} -test http11-1.12 "normal,identity,chunked" -setup { +test http11-1.12.$ThreadLevel "normal,identity,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -257,7 +307,7 @@ 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 { +test http11-1.13.$ThreadLevel "normal, 1.1 and keepalive as server default, no zip" -setup { variable httpd [create_httpd] set zipTmp [http::config -zip] http::config -zip 0 @@ -296,7 +346,7 @@ proc progressPause {var token total current} { return } -test http11-2.0 "-channel" -setup { +test http11-2.0.$ThreadLevel "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -314,7 +364,7 @@ test http11-2.0 "-channel" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close chunked} -test http11-2.1 "-channel, encoding gzip" -setup { +test http11-2.1.$ThreadLevel "-channel, encoding gzip" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -323,17 +373,42 @@ test http11-2.1 "-channel, encoding gzip" -setup { http::wait $tok seek $chan 0 set data [read $chan] + set diff [expr {[file size testdoc.html] - [file size testfile.tmp]}] list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ [meta $tok connection] [meta $tok content-encoding]\ - [meta $tok transfer-encoding] + [meta $tok transfer-encoding] -- $diff bytes lost } -cleanup { http::cleanup $tok close $chan removeFile testfile.tmp halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked} +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} -test http11-2.2 "-channel, encoding deflate" -setup { +# Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)" +# This test failed before the bugfix. +# The pass/fail depended on file size. +test http11-2.1.1.$ThreadLevel "-channel, encoding gzip" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set fileName largedoc.html +} -body { + set tok [http::geturl http://localhost:$httpd_port/$fileName \ + -timeout 5000 -channel $chan -headers {accept-encoding gzip}] + http::wait $tok + seek $chan 0 + set data [read $chan] + set diff [expr {[file size $fileName] - [file size testfile.tmp]}] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] -- $diff bytes lost +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} + +test http11-2.2.$ThreadLevel "-channel, encoding deflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -352,7 +427,28 @@ test http11-2.2 "-channel, encoding deflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} -test http11-2.3 "-channel,encoding compress" -setup { +test http11-2.2.1.$ThreadLevel "-channel, encoding deflate,msdeflate" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 5000 -channel $chan -headers {accept-encoding deflate}] + 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] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} + +test http11-2.3.$ThreadLevel "-channel,encoding compress" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -372,7 +468,7 @@ test http11-2.3 "-channel,encoding compress" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress chunked} -test http11-2.4 "-channel,encoding identity" -setup { +test http11-2.4.$ThreadLevel "-channel,encoding identity" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -392,7 +488,7 @@ 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 { +test http11-2.4.1.$ThreadLevel "-channel,encoding identity with -progress" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] set logdata "" @@ -418,7 +514,7 @@ test http11-2.4.1 "-channel,encoding identity with -progress" -setup { 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 { +test http11-2.4.2.$ThreadLevel "-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 "" @@ -444,7 +540,7 @@ test http11-2.4.2 "-channel,encoding identity with -progress progressPause enter 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 { +test http11-2.5.$ThreadLevel "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -464,7 +560,7 @@ test http11-2.5 "-channel,encoding unsupported" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} -test http11-2.6 "-channel,encoding gzip,non-chunked" -setup { +test http11-2.6.$ThreadLevel "-channel,encoding gzip,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -484,7 +580,7 @@ test http11-2.6 "-channel,encoding gzip,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0} -test http11-2.7 "-channel,encoding deflate,non-chunked" -setup { +test http11-2.7.$ThreadLevel "-channel,encoding deflate,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -504,7 +600,32 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} -test http11-2.8 "-channel,encoding compress,non-chunked" -setup { +test http11-2.7.1.$ThreadLevel "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup { + # Test fails because a -channel can only try one un-deflate algorithm, and the + # compliant "decompress" is tried, not the non-compliant "inflate" of + # the MS browser implementation. + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ + -timeout 5000 -channel $chan -headers {accept-encoding deflate}] + 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 {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} + +test http11-2.8.$ThreadLevel "-channel,encoding compress,non-chunked" -constraints badCompress -setup { + # The Tcl "compress" algorithm appears to be incorrect and has been removed. + # Bug [a13b9d0ce1]. variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -524,7 +645,7 @@ test http11-2.8 "-channel,encoding compress,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress {} 0} -test http11-2.9 "-channel,encoding identity,non-chunked" -setup { +test http11-2.9.$ThreadLevel "-channel,encoding identity,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -544,7 +665,7 @@ test http11-2.9 "-channel,encoding identity,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0} -test http11-2.10 "-channel,deflate,keepalive" -setup { +test http11-2.10.$ThreadLevel "-channel,deflate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -565,7 +686,28 @@ test http11-2.10 "-channel,deflate,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} -test http11-2.11 "-channel,identity,keepalive" -setup { +test http11-2.10.1.$ThreadLevel "-channel,deflate,keepalive,msdeflate" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ + -timeout 5000 -channel $chan -keepalive 1 \ + -headers {accept-encoding deflate}] + 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 {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} + +test http11-2.11.$ThreadLevel "-channel,identity,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -585,7 +727,7 @@ test http11-2.11 "-channel,identity,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {} chunked} -test http11-2.12 "-channel,negotiate,keepalive" -setup { +test http11-2.12.$ThreadLevel "-channel,negotiate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -603,7 +745,7 @@ test http11-2.12 "-channel,negotiate,keepalive" -setup { close $chan removeFile testfile.tmp halt_httpd -} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0} +} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0} # ------------------------------------------------------------------------- @@ -633,7 +775,7 @@ proc handlerPause {var sock token} { return [string length $chunk] } -test http11-3.0 "-handler,close,identity" -setup { +test http11-3.0.$ThreadLevel "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -650,7 +792,7 @@ test http11-3.0 "-handler,close,identity" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.1 "-handler,protocol1.0" -setup { +test http11-3.1.$ThreadLevel "-handler,protocol1.0" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -668,7 +810,7 @@ test http11-3.1 "-handler,protocol1.0" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.2 "-handler,close,chunked" -setup { +test http11-3.2.$ThreadLevel "-handler,close,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -686,7 +828,7 @@ test http11-3.2 "-handler,close,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.3 "-handler,keepalive,chunked" -setup { +test http11-3.3.$ThreadLevel "-handler,keepalive,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -714,7 +856,7 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { # "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 { +test http11-3.4.$ThreadLevel "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -732,7 +874,7 @@ test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connecti } -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 { +test http11-3.5.$ThreadLevel "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -749,7 +891,7 @@ test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters e 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 { +test http11-3.6.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress" -setup { variable httpd [create_httpd] set testdata "" set logdata "" @@ -770,7 +912,7 @@ test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setu 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 { +test http11-3.7.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" set logdata "" @@ -791,7 +933,7 @@ test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progre 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 { +test http11-3.8.$ThreadLevel "close,identity no -handler but with -progress" -setup { variable httpd [create_httpd] set logdata "" } -body { @@ -812,7 +954,7 @@ test http11-3.8 "close,identity no -handler but with -progress" -setup { 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 { +test http11-3.9.$ThreadLevel "close,identity no -handler but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set logdata "" } -body { @@ -833,7 +975,7 @@ test http11-3.9 "close,identity no -handler but with -progress progressPause ent halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} -test http11-4.0 "normal post request" -setup { +test http11-4.0.$ThreadLevel "normal post request" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] @@ -849,7 +991,7 @@ test http11-4.0 "normal post request" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} -test http11-4.1 "normal post request, check query length" -setup { +test http11-4.1.$ThreadLevel "normal post request, check query length" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] @@ -866,7 +1008,7 @@ test http11-4.1 "normal post request, check query length" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} -test http11-4.2 "normal post request, check long query length" -setup { +test http11-4.2.$ThreadLevel "normal post request, check long query length" -setup { variable httpd [create_httpd] } -body { set query [string repeat a 24576] @@ -883,7 +1025,7 @@ test http11-4.2 "normal post request, check long query length" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576} -test http11-4.3 "normal post request, check channel query length" -setup { +test http11-4.3.$ThreadLevel "normal post request, check channel query length" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192] @@ -918,6 +1060,7 @@ foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } removeFile testdoc.html +removeFile largedoc.html unset -nocomplain httpd_port httpd p ::tcltest::cleanupTests diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 4306149..491aae0 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -13,7 +13,31 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require http 2.9 +package require http 2.10 + +# ------------------------------------------------------------------------------ +# (0) Socket Creation in Thread, which triples the number of tests. +# ------------------------------------------------------------------------------ + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] @@ -815,7 +839,7 @@ for {set header 1} {$header <= 4} {incr header} { # Here's the test: - test httpPipeline-${header}.${footer}${label}-${tag} $name \ + test httpPipeline-${header}.${footer}${label}-${tag}-$ThreadLevel $name \ -constraints $cons \ -setup [string map [list TE $te] { # Restore default values for tests: diff --git a/tests/httpProxy.test b/tests/httpProxy.test new file mode 100644 index 0000000..d8bd6b7 --- /dev/null +++ b/tests/httpProxy.test @@ -0,0 +1,1146 @@ +# Commands covered: http::geturl when using a proxy server. +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. +# Copyright © 2022 Keith Nash. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +package require http 2.10 + +proc bgerror {args} { + global errorInfo + puts stderr "httpProxy.test bgerror" + puts stderr [join $args] + puts stderr $errorInfo +} + +proc stopMe {token} { + set ${token}(z) done +} + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel + + +#testConstraint needsSquid 1 +#testConstraint needsTls 1 + +if {[testConstraint needsTls]} { + package require tls + http::register https 443 [list ::tls::socket -ssl2 0 -ssl3 0 \ + -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 -autoservername 1] +} + +# Testing with Squid +# - Example Squid configuration for Enterprise Linux 8 (Red Hat, Oracle, Rocky, +# Alma, ...) is in file tests/httpProxySquidConfigForEL8.tar.gz. +# - Two instances of Squid are launched, one that needs authentication and one +# that does not. +# - Each instance of Squid listens on IPv4 and IPv6, on different ports. + +# Instance of Squid that does not need authentication. +set n4host 127.0.0.1 +set n6host ::1 +set n4port 3128 +set n6port 3130 + +# Instance of Squid that needs authentication. +set a4host 127.0.0.1 +set a6host ::1 +set a4port 3129 +set a6port 3131 + +# concat Basic [base64::encode alice:alicia] +set aliceCreds {Basic YWxpY2U6YWxpY2lh} + +# concat Basic [base64::encode intruder:intruder] +set badCreds {Basic aW50cnVkZXI6aW50cnVkZXI=} + +test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 noauth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://$n4host:$n4port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://\[$n6host\]:$n6port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 auth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://$a4host:$a4port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 auth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://\[$a6host\]:$a6port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res +} + +test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.7.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.7x.$ThreadLevel {http with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8x.$ThreadLevel {https with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9p.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9x.$ThreadLevel {http with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10p.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10x.$ThreadLevel {https with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.7.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.8.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9p.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10p.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { + http::cleanup $token + unset -nocomplain token ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.7.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.7p.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # Use the same caution as for the corresponding https test. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8p.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.9.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.10.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +# cleanup +unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds + +rename bgerror {} +rename stopMe {} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/httpProxySquidConfigForEL8.tar.gz b/tests/httpProxySquidConfigForEL8.tar.gz Binary files differnew file mode 100644 index 0000000..a94dbdb --- /dev/null +++ b/tests/httpProxySquidConfigForEL8.tar.gz diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 6a2226e..1dc6772 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -68,7 +68,11 @@ proc http::Log {args} { } return } - +# The http::Log routine above needs the variable ::httpTest::testOptions +# Set up to destroy it when that variable goes away. +trace add variable ::httpTest::testOptions unset {apply {args { + proc ::http::Log args {} +}}} # Called by http::Log (the "testing" version) to record logs for later analysis. diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index a40449a..5437bf6 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/httpcookie.test b/tests/httpcookie.test new file mode 100644 index 0000000..329330d --- /dev/null +++ b/tests/httpcookie.test @@ -0,0 +1,875 @@ +# Commands covered: http::cookiejar +# +# This file contains a collection of tests for the cookiejar package. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 2014 Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands + +testConstraint notMacCI [expr {![info exists ::env(MAC_CI)]}] +testConstraint sqlite3 [expr {[testConstraint notMacCI] && ![catch { + package require sqlite3 +}]}] +testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch { + package require cookiejar +}]}] + +set COOKIEJAR_VERSION 0.2.0 +test http-cookiejar-1.1 "cookie storage: packaging" {cookiejar} { + package require cookiejar +} $COOKIEJAR_VERSION +test http-cookiejar-1.2 "cookie storage: packaging" {cookiejar} { + package require cookiejar + package require cookiejar +} $COOKIEJAR_VERSION + +test http-cookiejar-2.1 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar +} -result {wrong # args: should be "http::cookiejar method ?arg ...?"} +test http-cookiejar-2.2 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar ? +} -result {unknown method "?": must be configure, create, destroy or new} +test http-cookiejar-2.3 "cookie storage: basics" -constraints { + cookiejar +} -body { + http::cookiejar configure +} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} +test http-cookiejar-2.4 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure a b c d e +} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} +test http-cookiejar-2.5 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure a +} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.6 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure -d +} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.7 "cookie storage: basics" -setup { + set old [http::cookiejar configure -loglevel] +} -constraints {cookiejar} -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel debug] \ + [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel error] \ + [http::cookiejar configure -loglevel] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug debug error error} +test http-cookiejar-2.8 "cookie storage: basics" -setup { + set old [http::cookiejar configure -loglevel] +} -constraints {cookiejar} -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel d] \ + [http::cookiejar configure -loglevel i] \ + [http::cookiejar configure -loglevel w] \ + [http::cookiejar configure -loglevel e] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug info warn error} +test http-cookiejar-2.9 "cookie storage: basics" -body { + http::cookiejar configure -off +} -constraints {cookiejar} -match glob -result * +test http-cookiejar-2.10 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline true +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -result 1 +test http-cookiejar-2.11 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline nonbool +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -returnCodes error -result {expected boolean value but got "nonbool"} +test http-cookiejar-2.12 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -purgeold] +} -constraints {cookiejar} -body { + http::cookiejar configure -purge nonint +} -cleanup { + catch {http::cookiejar configure -purgeold $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.13 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints {cookiejar} -body { + http::cookiejar configure -domainref nonint +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.14 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints {cookiejar} -body { + http::cookiejar configure -domainref -42 +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "-42"} +test http-cookiejar-2.15 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] + set result unset + set tracer [http::cookiejar create tracer] +} -constraints {cookiejar} -body { + oo::objdefine $tracer method PostponeRefresh {} { + set ::result set + next + } + http::cookiejar configure -domainref 12345 + return $result +} -cleanup { + $tracer destroy + catch {http::cookiejar configure -domainrefresh $oldval} +} -result set + +test http-cookiejar-3.1 "cookie storage: class" {cookiejar} { + info object isa object http::cookiejar +} 1 +test http-cookiejar-3.2 "cookie storage: class" {cookiejar} { + info object isa class http::cookiejar +} 1 +test http-cookiejar-3.3 "cookie storage: class" {cookiejar} { + lsort [info object methods http::cookiejar] +} {configure} +test http-cookiejar-3.4 "cookie storage: class" {cookiejar} { + lsort [info object methods http::cookiejar -all] +} {configure create destroy new} +test http-cookiejar-3.5 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + namespace eval :: {http::cookiejar create cookiejar} +} -cleanup { + catch {rename ::cookiejar ""} +} -result ::cookiejar +test http-cookiejar-3.6 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ + [::cookiejar destroy] [info commands ::cookiejar] +} -cleanup { + catch {rename ::cookiejar ""} +} -result {::cookiejar ::cookiejar {} {}} +test http-cookiejar-3.7 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar foo bar +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} +} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} +test http-cookiejar-3.8 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints {cookiejar} -body { + list [file exists $f] [http::cookiejar create ::cookiejar $f] \ + [file exists $f] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {0 ::cookiejar 1} +test http-cookiejar-3.9 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "bogus content for a database" cookiejar] +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -match glob -result * +test http-cookiejar-3.10 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set dir [makeDirectory cookiejar] +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $dir +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeDirectory $dir +} -match glob -result * + +test http-cookiejar-4.1 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar method ?arg ...?"} +test http-cookiejar-4.2 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar ? +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} +test http-cookiejar-4.3 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + lsort [info object methods cookiejar -all] +} -cleanup { + ::cookiejar destroy +} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} +test http-cookiejar-4.4 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar getCookies +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar getCookies proto host path"} +test http-cookiejar-4.5 "cookie storage" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar getCookies http www.example.com / +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.6 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar storeCookie options"} +test http-cookiejar-4.7 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.8 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.9 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.10 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.11 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.12 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.13 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.14 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.15 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.16 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo1 bar foo2 bar}} +test http-cookiejar-4.17 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar lookup a b c d +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} +test http-cookiejar-4.18 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [catch {cookiejar lookup www.example.com foo} value] $value + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] +} -cleanup { + ::cookiejar destroy +} -result {{} {} 1 {no such key for that host} www.example.com foo bar} +test http-cookiejar-4.19 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key bar + value foo + secure 0 + domain www.example.org + origin www.example.org + path / + hostonly 1 + } + lappend result [lsort [cookiejar lookup]] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] + lappend result [cookiejar lookup www.example.org] + lappend result [cookiejar lookup www.example.org bar] +} -cleanup { + ::cookiejar destroy +} -result {{www.example.com www.example.org} foo bar bar foo} +test http-cookiejar-4.20 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.21 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.22 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar forceLoadDomainData x y z +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar forceLoadDomainData"} +test http-cookiejar-4.23 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar forceLoadDomainData +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.23.a {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline 1 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} +test http-cookiejar-4.23.b {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline 0 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} + +test http-cookiejar-5.1 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain com + origin com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.2 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain foo.example.com + origin bar.example.org + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.3 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {example.com} +test http-cookiejar-5.4 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo + value bar2 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + lsort [cookiejar lookup] +} -cleanup { + ::cookiejar destroy +} -result {example.com www.example.com} +test http-cookiejar-5.5 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value 1 + secure 0 + domain com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo2 + value 2 + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo3 + value 3 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo4 + value 4 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo5 + value 5 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo6 + value 6 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo7 + value 7 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo8 + value 8 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo9 + value 9 + secure 0 + domain sub.www.example.com + origin www.example.com + path / + hostonly 1 + } + list [cookiejar getCookies http www.example.com /] \ + [cookiejar getCookies http www2.example.com /] \ + [cookiejar getCookies https www.example.com /] \ + [cookiejar getCookies http sub.www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} + +test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup { + http::cookiejar create ::cookiejar + oo::objdefine cookiejar export PurgeCookies + set result {} + proc values cookies { + global result + lappend result [lsort [lmap {k v} $cookies {set v}]] + } +} -constraints {cookiejar} -body { + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session-global + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + values [cookiejar getCookies http www.example.com /] + after 2500 + update + values [cookiejar getCookies http www.example.com /] + cookiejar PurgeCookies + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value go-away + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + expires 0 + } + values [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} + +test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f + ::cookiejar destroy + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f + set result {} +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar $f + lappend result [::cookiejar getCookies http www.example.com /] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {{foo cookie} {} {foo cookie}} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: diff --git a/tests/httpd b/tests/httpd index 48e14ea..a7b42a1 100644 --- a/tests/httpd +++ b/tests/httpd @@ -2,8 +2,8 @@ # # 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. @@ -16,7 +16,12 @@ set HOST localhost proc httpd_init {{port 8015}} { - socket -server httpdAccept $port + set s [socket -server httpdAccept $port] + # Save the actual port number in a global variable. + # This is important when we're called with port 0 + # for picking an unused port at random. + set ::port [lindex [chan configure $s -sockname] 2] + return $s } proc httpd_log {args} { global httpLog diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 89590ec..9e0edcd 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -3,12 +3,12 @@ # A simple httpd for testing HTTP/1.1 client features. # Not suitable for use on a internet connected port. # -# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> +# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6- +package require Tcl proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { @@ -46,7 +46,7 @@ proc get-chunks {data {compression gzip}} { } set data "" - set chunker [make-chunk-generator $data 512] + set chunker [make-chunk-generator $data 671] while {[string length [set chunk [$chunker]]]} { append data $chunk } @@ -60,7 +60,7 @@ proc blow-chunks {data {ochan stdout} {compression gzip}} { compress { set data [zlib compress $data] } } - set chunker [make-chunk-generator $data 512] + set chunker [make-chunk-generator $data 671] while {[string length [set chunk [$chunker]]]} { puts -nonewline $ochan $chunk } @@ -150,7 +150,11 @@ proc Service {chan addr port} { if {[file exists $path] && [file isfile $path]} { foreach {what type} [mime-type $path] break set f [open $path r] - if {$what eq "binary"} {chan configure $f -translation binary} + if {$what eq "binary"} { + chan configure $f -translation binary + } else { + chan configure $f -encoding utf-8 + } set data [read $f] close $f set code "200 OK" @@ -160,6 +164,12 @@ proc Service {chan addr port} { if {$protocol eq "HTTP/1.1"} { foreach enc [split [dict get? $meta accept-encoding] ,] { set enc [string trim $enc] + # The current implementation of "compress" appears to be + # incorrect (bug [a13b9d0ce1]). Keep it here for + # experimentation only. The tests that use it have the + # constraint "badCompress". The client code in http has + # been removed, but can be restored from comments if + # experimentation is desired. if {$enc in {deflate gzip compress}} { set encoding $enc break @@ -171,6 +181,7 @@ proc Service {chan addr port} { } set nosendclose 0 + set msdeflate 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { @@ -178,6 +189,7 @@ proc Service {chan addr port} { close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} + msdeflate {set msdeflate $val} } } if {$protocol eq "HTTP/1.1"} { @@ -211,10 +223,23 @@ proc Service {chan addr port} { flush $chan chan configure $chan -buffering full -translation binary + if {$encoding eq {deflate}} { + # When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for + # "accept-encoding deflate", i.e. "zlib decompress", this choice of + # encoding2 allows the tests to pass. It appears to do "deflate" + # correctly, but this has not been verified with a non-Tcl client. + set encoding2 compress + } else { + set encoding2 $encoding + } if {$transfer eq "chunked"} { - blow-chunks $data $chan $encoding - } elseif {$encoding ne "identity"} { - puts -nonewline $chan [zlib $encoding $data] + blow-chunks $data $chan $encoding2 + } elseif {$encoding2 ne "identity" && $msdeflate eq {1}} { + puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4] + # Used in some tests of "deflate" to produce the non-RFC-compliant + # Microsoft version of "deflate". + } elseif {$encoding2 ne "identity"} { + puts -nonewline $chan [zlib $encoding2 $data] } else { puts -nonewline $chan $data } diff --git a/tests/httpold.test b/tests/httpold.test deleted file mode 100644 index e760c92..0000000 --- a/tests/httpold.test +++ /dev/null @@ -1,306 +0,0 @@ -# Commands covered: http_config, http_get, http_wait, http_reset -# -# This file contains a collection of tests for the http script library. -# Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -if {[catch {package require http 1.0}]} { - if {[info exists httpold]} { - catch {puts "Cannot load http 1.0 package"} - ::tcltest::cleanupTests - return - } else { - catch {puts "Running http 1.0 tests in child interp"} - set interp [interp create httpold] - $interp eval [list set httpold "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - ::tcltest::cleanupTests - return - } -} - -# 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} - -## -## The httpd script implement a stub http server -## Sourcing httpd overwrites the value of HOST. -## -source [file join [file dirname [info script]] httpd] - -set port 8010 -if {[catch {httpd_init $port} listen]} { - puts "Cannot start http server, http test skipped" - unset port - ::tcltest::cleanupTests - return -} - -test httpold-1.1 {http_config} { - http_config -} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} - -test httpold-1.2 {http_config} { - http_config -proxyfilter -} httpProxyRequired - -test httpold-1.3 {http_config} { - catch {http_config -junk} -} 1 - -test httpold-1.4 {http_config} { - http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http_config] - http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ - -useragent "Tcl http client package 1.0" - set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - -test httpold-1.5 {http_config} { - catch {http_config -proxyhost {} -junk 8080} -} 1 - -test httpold-2.1 {http_reset} { - catch {http_reset http#1} -} 0 - -test httpold-3.1 {http_get} { - catch {http_get -bogus flag} -} 1 -test httpold-3.2 {http_get} { - catch {http_get http:junk} err - set err -} {Unsupported URL: http:junk} - -set url ${::HOST}:$port -test httpold-3.3 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET /</h2> -</body></html>" - -set tail /a/b/c -set url ${::HOST}:$port/a/b/c -set binurl ${::HOST}:$port/binary - -test httpold-3.4 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -proc selfproxy {host} { - global port - return [list ${::HOST} $port] -} -test httpold-3.5 {http_get} { - http_config -proxyfilter selfproxy - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -test httpold-3.6 {http_get} { - http_config -proxyfilter bogus - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.7 {http_get} { - set token [http_get $url -headers {Pragma no-cache}] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.8 {http_get} { - set token [http_get $url -query Name=Value&Foo=Bar] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>POST $tail</h2> -<h2>Query</h2> -<dl> -<dt>Name<dd>Value -<dt>Foo<dd>Bar -</dl> -</body></html>" - -test httpold-3.9 {http_get} { - set token [http_get $url -validate 1] - http_code $token -} "HTTP/1.0 200 OK" - - -test httpold-4.1 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - expr {$data(totalsize) == $meta(Content-Length)} -} 1 - -test httpold-4.2 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test httpold-4.3 {httpEvent} { - set token [http_get $url] - http_code $token -} {HTTP/1.0 200 Data follows} - -test httpold-4.4 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - set in [open $testfile] - set x [read $in] - close $in - removeFile $testfile - set x -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-4.5 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - upvar #0 $token data - removeFile $testfile - expr {$data(currentsize) == $data(totalsize)} -} 1 - -test httpold-4.6 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $binurl -channel $out] - close $out - set in [open $testfile] - fconfigure $in -translation binary - set x [read $in] - close $in - removeFile $testfile - set x -} "$bindata$binurl" - -proc myProgress {token total current} { - global progress httpLog - if {[info exists httpLog] && $httpLog} { - puts "progress $total $current" - } - set progress [list $total $current] -} -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test httpold-4.6 {httpEvent} { - set token [http_get $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test httpold-4.7 {httpEvent} { - set token [http_get $url -progress myProgress] - set progress -} {111 111} -test httpold-4.8 {httpEvent} { - set token [http_get $url] - http_status $token -} {ok} -test httpold-4.9 {httpEvent} { - set token [http_get $url -progress myProgress] - http_code $token -} {HTTP/1.0 200 Data follows} -test httpold-4.10 {httpEvent} { - set token [http_get $url -progress myProgress] - http_size $token -} {111} -test httpold-4.11 {httpEvent} { - set token [http_get $url -timeout 1 -command {#}] - http_reset $token - http_status $token -} {reset} -test httpold-4.12 {httpEvent} -body { - set tout {} - update - set x {} - set token [http_get $url?delay=500 -timeout 1 -command {lappend x fail}] - set i 0; while {$x eq {} && [incr i] < 50} { - set tout [after 20 {set x progress}] - vwait x - if {$x ne "progress"} break - set x [http_status $token] - } - set x -} -cleanup { - if {$tout ne {}} {after cancel $tout} -} -result timeout - -test httpold-5.1 {http_formatQuery} { - http_formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test httpold-5.2 {http_formatQuery} { - http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - -test httpold-5.3 {http_formatQuery} { - http_formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} - -test httpold-6.1 {httpProxyRequired} { - update - http_config -proxyhost ${::HOST} -proxyport $port - set token [http_get $url] - http_wait $token - http_config -proxyhost {} -proxyport {} - upvar #0 $token data - set data(body) -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -# cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen -::tcltest::cleanupTests -return diff --git a/tests/icuUcmTests.tcl b/tests/icuUcmTests.tcl new file mode 100644 index 0000000..3b70748 --- /dev/null +++ b/tests/icuUcmTests.tcl @@ -0,0 +1,1891 @@ + +# This file is automatically generated by ucm2tests.tcl. +# Edits will be overwritten on next generation. +# +# Generates tests comparing Tcl encodings to ICU. +# The generated file is NOT standalone. It should be sourced into a test script. + +proc ucmConvertfromMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits + set unich [subst "\\U$unihex"] + if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +proc ucmConverttoMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits + set unich [subst "\\U$unihex"] + if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +if {[info commands printable] eq ""} { + proc printable {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print + } +} + + +# +# cp1250 (generated from glibc-CP1250-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1250 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1250 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1250 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1250 81 tcl8 \U00000081 -1 {} {} + cp1250 81 replace \uFFFD -1 {} {} + cp1250 81 strict {} 0 {} {} + cp1250 83 tcl8 \U00000083 -1 {} {} + cp1250 83 replace \uFFFD -1 {} {} + cp1250 83 strict {} 0 {} {} + cp1250 88 tcl8 \U00000088 -1 {} {} + cp1250 88 replace \uFFFD -1 {} {} + cp1250 88 strict {} 0 {} {} + cp1250 90 tcl8 \U00000090 -1 {} {} + cp1250 90 replace \uFFFD -1 {} {} + cp1250 90 strict {} 0 {} {} + cp1250 98 tcl8 \U00000098 -1 {} {} + cp1250 98 replace \uFFFD -1 {} {} + cp1250 98 strict {} 0 {} {} +}; # cp1250 + +# cp1250 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1250 \U00000080 tcl8 1A -1 {} {} + cp1250 \U00000080 replace 1A -1 {} {} + cp1250 \U00000080 strict {} 0 {} {} + cp1250 \U00000400 tcl8 1A -1 {} {} + cp1250 \U00000400 replace 1A -1 {} {} + cp1250 \U00000400 strict {} 0 {} {} + cp1250 \U0000D800 tcl8 1A -1 {} {} + cp1250 \U0000D800 replace 1A -1 {} {} + cp1250 \U0000D800 strict {} 0 {} {} + cp1250 \U0000DC00 tcl8 1A -1 {} {} + cp1250 \U0000DC00 replace 1A -1 {} {} + cp1250 \U0000DC00 strict {} 0 {} {} + cp1250 \U00010000 tcl8 1A -1 {} {} + cp1250 \U00010000 replace 1A -1 {} {} + cp1250 \U00010000 strict {} 0 {} {} + cp1250 \U0010FFFF tcl8 1A -1 {} {} + cp1250 \U0010FFFF replace 1A -1 {} {} + cp1250 \U0010FFFF strict {} 0 {} {} +}; # cp1250 + +# +# cp1251 (generated from glibc-CP1251-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1251 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1251 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99} +} -result {} + +# cp1251 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1251 98 tcl8 \U00000098 -1 {} {} + cp1251 98 replace \uFFFD -1 {} {} + cp1251 98 strict {} 0 {} {} +}; # cp1251 + +# cp1251 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1251 \U00000080 tcl8 1A -1 {} {} + cp1251 \U00000080 replace 1A -1 {} {} + cp1251 \U00000080 strict {} 0 {} {} + cp1251 \U00000400 tcl8 1A -1 {} {} + cp1251 \U00000400 replace 1A -1 {} {} + cp1251 \U00000400 strict {} 0 {} {} + cp1251 \U0000D800 tcl8 1A -1 {} {} + cp1251 \U0000D800 replace 1A -1 {} {} + cp1251 \U0000D800 strict {} 0 {} {} + cp1251 \U0000DC00 tcl8 1A -1 {} {} + cp1251 \U0000DC00 replace 1A -1 {} {} + cp1251 \U0000DC00 strict {} 0 {} {} + cp1251 \U00010000 tcl8 1A -1 {} {} + cp1251 \U00010000 replace 1A -1 {} {} + cp1251 \U00010000 strict {} 0 {} {} + cp1251 \U0010FFFF tcl8 1A -1 {} {} + cp1251 \U0010FFFF replace 1A -1 {} {} + cp1251 \U0010FFFF strict {} 0 {} {} +}; # cp1251 + +# +# cp1252 (generated from glibc-CP1252-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1252 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1252 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1252 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1252 81 tcl8 \U00000081 -1 {} {} + cp1252 81 replace \uFFFD -1 {} {} + cp1252 81 strict {} 0 {} {} + cp1252 8D tcl8 \U0000008D -1 {} {} + cp1252 8D replace \uFFFD -1 {} {} + cp1252 8D strict {} 0 {} {} + cp1252 8F tcl8 \U0000008F -1 {} {} + cp1252 8F replace \uFFFD -1 {} {} + cp1252 8F strict {} 0 {} {} + cp1252 90 tcl8 \U00000090 -1 {} {} + cp1252 90 replace \uFFFD -1 {} {} + cp1252 90 strict {} 0 {} {} + cp1252 9D tcl8 \U0000009D -1 {} {} + cp1252 9D replace \uFFFD -1 {} {} + cp1252 9D strict {} 0 {} {} +}; # cp1252 + +# cp1252 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1252 \U00000080 tcl8 1A -1 {} {} + cp1252 \U00000080 replace 1A -1 {} {} + cp1252 \U00000080 strict {} 0 {} {} + cp1252 \U00000400 tcl8 1A -1 {} {} + cp1252 \U00000400 replace 1A -1 {} {} + cp1252 \U00000400 strict {} 0 {} {} + cp1252 \U0000D800 tcl8 1A -1 {} {} + cp1252 \U0000D800 replace 1A -1 {} {} + cp1252 \U0000D800 strict {} 0 {} {} + cp1252 \U0000DC00 tcl8 1A -1 {} {} + cp1252 \U0000DC00 replace 1A -1 {} {} + cp1252 \U0000DC00 strict {} 0 {} {} + cp1252 \U00010000 tcl8 1A -1 {} {} + cp1252 \U00010000 replace 1A -1 {} {} + cp1252 \U00010000 strict {} 0 {} {} + cp1252 \U0010FFFF tcl8 1A -1 {} {} + cp1252 \U0010FFFF replace 1A -1 {} {} + cp1252 \U0010FFFF strict {} 0 {} {} +}; # cp1252 + +# +# cp1253 (generated from glibc-CP1253-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1253 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1253 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1253 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1253 81 tcl8 \U00000081 -1 {} {} + cp1253 81 replace \uFFFD -1 {} {} + cp1253 81 strict {} 0 {} {} + cp1253 88 tcl8 \U00000088 -1 {} {} + cp1253 88 replace \uFFFD -1 {} {} + cp1253 88 strict {} 0 {} {} + cp1253 8A tcl8 \U0000008A -1 {} {} + cp1253 8A replace \uFFFD -1 {} {} + cp1253 8A strict {} 0 {} {} + cp1253 8C tcl8 \U0000008C -1 {} {} + cp1253 8C replace \uFFFD -1 {} {} + cp1253 8C strict {} 0 {} {} + cp1253 8D tcl8 \U0000008D -1 {} {} + cp1253 8D replace \uFFFD -1 {} {} + cp1253 8D strict {} 0 {} {} + cp1253 8E tcl8 \U0000008E -1 {} {} + cp1253 8E replace \uFFFD -1 {} {} + cp1253 8E strict {} 0 {} {} + cp1253 8F tcl8 \U0000008F -1 {} {} + cp1253 8F replace \uFFFD -1 {} {} + cp1253 8F strict {} 0 {} {} + cp1253 90 tcl8 \U00000090 -1 {} {} + cp1253 90 replace \uFFFD -1 {} {} + cp1253 90 strict {} 0 {} {} + cp1253 98 tcl8 \U00000098 -1 {} {} + cp1253 98 replace \uFFFD -1 {} {} + cp1253 98 strict {} 0 {} {} + cp1253 9A tcl8 \U0000009A -1 {} {} + cp1253 9A replace \uFFFD -1 {} {} + cp1253 9A strict {} 0 {} {} + cp1253 9C tcl8 \U0000009C -1 {} {} + cp1253 9C replace \uFFFD -1 {} {} + cp1253 9C strict {} 0 {} {} + cp1253 9D tcl8 \U0000009D -1 {} {} + cp1253 9D replace \uFFFD -1 {} {} + cp1253 9D strict {} 0 {} {} + cp1253 9E tcl8 \U0000009E -1 {} {} + cp1253 9E replace \uFFFD -1 {} {} + cp1253 9E strict {} 0 {} {} + cp1253 9F tcl8 \U0000009F -1 {} {} + cp1253 9F replace \uFFFD -1 {} {} + cp1253 9F strict {} 0 {} {} + cp1253 AA tcl8 \U000000AA -1 {} {} + cp1253 AA replace \uFFFD -1 {} {} + cp1253 AA strict {} 0 {} {} + cp1253 D2 tcl8 \U000000D2 -1 {} {} + cp1253 D2 replace \uFFFD -1 {} {} + cp1253 D2 strict {} 0 {} {} + cp1253 FF tcl8 \U000000FF -1 {} {} + cp1253 FF replace \uFFFD -1 {} {} + cp1253 FF strict {} 0 {} {} +}; # cp1253 + +# cp1253 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1253 \U00000080 tcl8 1A -1 {} {} + cp1253 \U00000080 replace 1A -1 {} {} + cp1253 \U00000080 strict {} 0 {} {} + cp1253 \U00000400 tcl8 1A -1 {} {} + cp1253 \U00000400 replace 1A -1 {} {} + cp1253 \U00000400 strict {} 0 {} {} + cp1253 \U0000D800 tcl8 1A -1 {} {} + cp1253 \U0000D800 replace 1A -1 {} {} + cp1253 \U0000D800 strict {} 0 {} {} + cp1253 \U0000DC00 tcl8 1A -1 {} {} + cp1253 \U0000DC00 replace 1A -1 {} {} + cp1253 \U0000DC00 strict {} 0 {} {} + cp1253 \U00010000 tcl8 1A -1 {} {} + cp1253 \U00010000 replace 1A -1 {} {} + cp1253 \U00010000 strict {} 0 {} {} + cp1253 \U0010FFFF tcl8 1A -1 {} {} + cp1253 \U0010FFFF replace 1A -1 {} {} + cp1253 \U0010FFFF strict {} 0 {} {} +}; # cp1253 + +# +# cp1254 (generated from glibc-CP1254-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1254 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1254 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1254 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1254 81 tcl8 \U00000081 -1 {} {} + cp1254 81 replace \uFFFD -1 {} {} + cp1254 81 strict {} 0 {} {} + cp1254 8D tcl8 \U0000008D -1 {} {} + cp1254 8D replace \uFFFD -1 {} {} + cp1254 8D strict {} 0 {} {} + cp1254 8E tcl8 \U0000008E -1 {} {} + cp1254 8E replace \uFFFD -1 {} {} + cp1254 8E strict {} 0 {} {} + cp1254 8F tcl8 \U0000008F -1 {} {} + cp1254 8F replace \uFFFD -1 {} {} + cp1254 8F strict {} 0 {} {} + cp1254 90 tcl8 \U00000090 -1 {} {} + cp1254 90 replace \uFFFD -1 {} {} + cp1254 90 strict {} 0 {} {} + cp1254 9D tcl8 \U0000009D -1 {} {} + cp1254 9D replace \uFFFD -1 {} {} + cp1254 9D strict {} 0 {} {} + cp1254 9E tcl8 \U0000009E -1 {} {} + cp1254 9E replace \uFFFD -1 {} {} + cp1254 9E strict {} 0 {} {} +}; # cp1254 + +# cp1254 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1254 \U00000080 tcl8 1A -1 {} {} + cp1254 \U00000080 replace 1A -1 {} {} + cp1254 \U00000080 strict {} 0 {} {} + cp1254 \U00000400 tcl8 1A -1 {} {} + cp1254 \U00000400 replace 1A -1 {} {} + cp1254 \U00000400 strict {} 0 {} {} + cp1254 \U0000D800 tcl8 1A -1 {} {} + cp1254 \U0000D800 replace 1A -1 {} {} + cp1254 \U0000D800 strict {} 0 {} {} + cp1254 \U0000DC00 tcl8 1A -1 {} {} + cp1254 \U0000DC00 replace 1A -1 {} {} + cp1254 \U0000DC00 strict {} 0 {} {} + cp1254 \U00010000 tcl8 1A -1 {} {} + cp1254 \U00010000 replace 1A -1 {} {} + cp1254 \U00010000 strict {} 0 {} {} + cp1254 \U0010FFFF tcl8 1A -1 {} {} + cp1254 \U0010FFFF replace 1A -1 {} {} + cp1254 \U0010FFFF strict {} 0 {} {} +}; # cp1254 + +# +# cp1255 (generated from glibc-CP1255-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1255 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1255 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99} +} -result {} + +# cp1255 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1255 81 tcl8 \U00000081 -1 {} {} + cp1255 81 replace \uFFFD -1 {} {} + cp1255 81 strict {} 0 {} {} + cp1255 8A tcl8 \U0000008A -1 {} {} + cp1255 8A replace \uFFFD -1 {} {} + cp1255 8A strict {} 0 {} {} + cp1255 8C tcl8 \U0000008C -1 {} {} + cp1255 8C replace \uFFFD -1 {} {} + cp1255 8C strict {} 0 {} {} + cp1255 8D tcl8 \U0000008D -1 {} {} + cp1255 8D replace \uFFFD -1 {} {} + cp1255 8D strict {} 0 {} {} + cp1255 8E tcl8 \U0000008E -1 {} {} + cp1255 8E replace \uFFFD -1 {} {} + cp1255 8E strict {} 0 {} {} + cp1255 8F tcl8 \U0000008F -1 {} {} + cp1255 8F replace \uFFFD -1 {} {} + cp1255 8F strict {} 0 {} {} + cp1255 90 tcl8 \U00000090 -1 {} {} + cp1255 90 replace \uFFFD -1 {} {} + cp1255 90 strict {} 0 {} {} + cp1255 9A tcl8 \U0000009A -1 {} {} + cp1255 9A replace \uFFFD -1 {} {} + cp1255 9A strict {} 0 {} {} + cp1255 9C tcl8 \U0000009C -1 {} {} + cp1255 9C replace \uFFFD -1 {} {} + cp1255 9C strict {} 0 {} {} + cp1255 9D tcl8 \U0000009D -1 {} {} + cp1255 9D replace \uFFFD -1 {} {} + cp1255 9D strict {} 0 {} {} + cp1255 9E tcl8 \U0000009E -1 {} {} + cp1255 9E replace \uFFFD -1 {} {} + cp1255 9E strict {} 0 {} {} + cp1255 9F tcl8 \U0000009F -1 {} {} + cp1255 9F replace \uFFFD -1 {} {} + cp1255 9F strict {} 0 {} {} + cp1255 CA tcl8 \U000000CA -1 {} {} + cp1255 CA replace \uFFFD -1 {} {} + cp1255 CA strict {} 0 {} {} + cp1255 D9 tcl8 \U000000D9 -1 {} {} + cp1255 D9 replace \uFFFD -1 {} {} + cp1255 D9 strict {} 0 {} {} + cp1255 DA tcl8 \U000000DA -1 {} {} + cp1255 DA replace \uFFFD -1 {} {} + cp1255 DA strict {} 0 {} {} + cp1255 DB tcl8 \U000000DB -1 {} {} + cp1255 DB replace \uFFFD -1 {} {} + cp1255 DB strict {} 0 {} {} + cp1255 DC tcl8 \U000000DC -1 {} {} + cp1255 DC replace \uFFFD -1 {} {} + cp1255 DC strict {} 0 {} {} + cp1255 DD tcl8 \U000000DD -1 {} {} + cp1255 DD replace \uFFFD -1 {} {} + cp1255 DD strict {} 0 {} {} + cp1255 DE tcl8 \U000000DE -1 {} {} + cp1255 DE replace \uFFFD -1 {} {} + cp1255 DE strict {} 0 {} {} + cp1255 DF tcl8 \U000000DF -1 {} {} + cp1255 DF replace \uFFFD -1 {} {} + cp1255 DF strict {} 0 {} {} + cp1255 FB tcl8 \U000000FB -1 {} {} + cp1255 FB replace \uFFFD -1 {} {} + cp1255 FB strict {} 0 {} {} + cp1255 FC tcl8 \U000000FC -1 {} {} + cp1255 FC replace \uFFFD -1 {} {} + cp1255 FC strict {} 0 {} {} + cp1255 FF tcl8 \U000000FF -1 {} {} + cp1255 FF replace \uFFFD -1 {} {} + cp1255 FF strict {} 0 {} {} +}; # cp1255 + +# cp1255 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1255 \U00000080 tcl8 1A -1 {} {} + cp1255 \U00000080 replace 1A -1 {} {} + cp1255 \U00000080 strict {} 0 {} {} + cp1255 \U00000400 tcl8 1A -1 {} {} + cp1255 \U00000400 replace 1A -1 {} {} + cp1255 \U00000400 strict {} 0 {} {} + cp1255 \U0000D800 tcl8 1A -1 {} {} + cp1255 \U0000D800 replace 1A -1 {} {} + cp1255 \U0000D800 strict {} 0 {} {} + cp1255 \U0000DC00 tcl8 1A -1 {} {} + cp1255 \U0000DC00 replace 1A -1 {} {} + cp1255 \U0000DC00 strict {} 0 {} {} + cp1255 \U00010000 tcl8 1A -1 {} {} + cp1255 \U00010000 replace 1A -1 {} {} + cp1255 \U00010000 strict {} 0 {} {} + cp1255 \U0010FFFF tcl8 1A -1 {} {} + cp1255 \U0010FFFF replace 1A -1 {} {} + cp1255 \U0010FFFF strict {} 0 {} {} +}; # cp1255 + +# +# cp1256 (generated from glibc-CP1256-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1256 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1256 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1256 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # cp1256 + +# cp1256 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1256 \U00000080 tcl8 1A -1 {} {} + cp1256 \U00000080 replace 1A -1 {} {} + cp1256 \U00000080 strict {} 0 {} {} + cp1256 \U00000400 tcl8 1A -1 {} {} + cp1256 \U00000400 replace 1A -1 {} {} + cp1256 \U00000400 strict {} 0 {} {} + cp1256 \U0000D800 tcl8 1A -1 {} {} + cp1256 \U0000D800 replace 1A -1 {} {} + cp1256 \U0000D800 strict {} 0 {} {} + cp1256 \U0000DC00 tcl8 1A -1 {} {} + cp1256 \U0000DC00 replace 1A -1 {} {} + cp1256 \U0000DC00 strict {} 0 {} {} + cp1256 \U00010000 tcl8 1A -1 {} {} + cp1256 \U00010000 replace 1A -1 {} {} + cp1256 \U00010000 strict {} 0 {} {} + cp1256 \U0010FFFF tcl8 1A -1 {} {} + cp1256 \U0010FFFF replace 1A -1 {} {} + cp1256 \U0010FFFF strict {} 0 {} {} +}; # cp1256 + +# +# cp1257 (generated from glibc-CP1257-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1257 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1257 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1257 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1257 81 tcl8 \U00000081 -1 {} {} + cp1257 81 replace \uFFFD -1 {} {} + cp1257 81 strict {} 0 {} {} + cp1257 83 tcl8 \U00000083 -1 {} {} + cp1257 83 replace \uFFFD -1 {} {} + cp1257 83 strict {} 0 {} {} + cp1257 88 tcl8 \U00000088 -1 {} {} + cp1257 88 replace \uFFFD -1 {} {} + cp1257 88 strict {} 0 {} {} + cp1257 8A tcl8 \U0000008A -1 {} {} + cp1257 8A replace \uFFFD -1 {} {} + cp1257 8A strict {} 0 {} {} + cp1257 8C tcl8 \U0000008C -1 {} {} + cp1257 8C replace \uFFFD -1 {} {} + cp1257 8C strict {} 0 {} {} + cp1257 90 tcl8 \U00000090 -1 {} {} + cp1257 90 replace \uFFFD -1 {} {} + cp1257 90 strict {} 0 {} {} + cp1257 98 tcl8 \U00000098 -1 {} {} + cp1257 98 replace \uFFFD -1 {} {} + cp1257 98 strict {} 0 {} {} + cp1257 9A tcl8 \U0000009A -1 {} {} + cp1257 9A replace \uFFFD -1 {} {} + cp1257 9A strict {} 0 {} {} + cp1257 9C tcl8 \U0000009C -1 {} {} + cp1257 9C replace \uFFFD -1 {} {} + cp1257 9C strict {} 0 {} {} + cp1257 9F tcl8 \U0000009F -1 {} {} + cp1257 9F replace \uFFFD -1 {} {} + cp1257 9F strict {} 0 {} {} + cp1257 A1 tcl8 \U000000A1 -1 {} {} + cp1257 A1 replace \uFFFD -1 {} {} + cp1257 A1 strict {} 0 {} {} + cp1257 A5 tcl8 \U000000A5 -1 {} {} + cp1257 A5 replace \uFFFD -1 {} {} + cp1257 A5 strict {} 0 {} {} +}; # cp1257 + +# cp1257 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1257 \U00000080 tcl8 1A -1 {} {} + cp1257 \U00000080 replace 1A -1 {} {} + cp1257 \U00000080 strict {} 0 {} {} + cp1257 \U00000400 tcl8 1A -1 {} {} + cp1257 \U00000400 replace 1A -1 {} {} + cp1257 \U00000400 strict {} 0 {} {} + cp1257 \U0000D800 tcl8 1A -1 {} {} + cp1257 \U0000D800 replace 1A -1 {} {} + cp1257 \U0000D800 strict {} 0 {} {} + cp1257 \U0000DC00 tcl8 1A -1 {} {} + cp1257 \U0000DC00 replace 1A -1 {} {} + cp1257 \U0000DC00 strict {} 0 {} {} + cp1257 \U00010000 tcl8 1A -1 {} {} + cp1257 \U00010000 replace 1A -1 {} {} + cp1257 \U00010000 strict {} 0 {} {} + cp1257 \U0010FFFF tcl8 1A -1 {} {} + cp1257 \U0010FFFF replace 1A -1 {} {} + cp1257 \U0010FFFF strict {} 0 {} {} +}; # cp1257 + +# +# cp1258 (generated from glibc-CP1258-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1258 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1258 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99} +} -result {} + +# cp1258 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1258 81 tcl8 \U00000081 -1 {} {} + cp1258 81 replace \uFFFD -1 {} {} + cp1258 81 strict {} 0 {} {} + cp1258 8A tcl8 \U0000008A -1 {} {} + cp1258 8A replace \uFFFD -1 {} {} + cp1258 8A strict {} 0 {} {} + cp1258 8D tcl8 \U0000008D -1 {} {} + cp1258 8D replace \uFFFD -1 {} {} + cp1258 8D strict {} 0 {} {} + cp1258 8E tcl8 \U0000008E -1 {} {} + cp1258 8E replace \uFFFD -1 {} {} + cp1258 8E strict {} 0 {} {} + cp1258 8F tcl8 \U0000008F -1 {} {} + cp1258 8F replace \uFFFD -1 {} {} + cp1258 8F strict {} 0 {} {} + cp1258 90 tcl8 \U00000090 -1 {} {} + cp1258 90 replace \uFFFD -1 {} {} + cp1258 90 strict {} 0 {} {} + cp1258 9A tcl8 \U0000009A -1 {} {} + cp1258 9A replace \uFFFD -1 {} {} + cp1258 9A strict {} 0 {} {} + cp1258 9D tcl8 \U0000009D -1 {} {} + cp1258 9D replace \uFFFD -1 {} {} + cp1258 9D strict {} 0 {} {} + cp1258 9E tcl8 \U0000009E -1 {} {} + cp1258 9E replace \uFFFD -1 {} {} + cp1258 9E strict {} 0 {} {} + cp1258 EC tcl8 \U000000EC -1 {} {} + cp1258 EC replace \uFFFD -1 {} {} + cp1258 EC strict {} 0 {} {} +}; # cp1258 + +# cp1258 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1258 \U00000080 tcl8 1A -1 {} {} + cp1258 \U00000080 replace 1A -1 {} {} + cp1258 \U00000080 strict {} 0 {} {} + cp1258 \U00000400 tcl8 1A -1 {} {} + cp1258 \U00000400 replace 1A -1 {} {} + cp1258 \U00000400 strict {} 0 {} {} + cp1258 \U0000D800 tcl8 1A -1 {} {} + cp1258 \U0000D800 replace 1A -1 {} {} + cp1258 \U0000D800 strict {} 0 {} {} + cp1258 \U0000DC00 tcl8 1A -1 {} {} + cp1258 \U0000DC00 replace 1A -1 {} {} + cp1258 \U0000DC00 strict {} 0 {} {} + cp1258 \U00010000 tcl8 1A -1 {} {} + cp1258 \U00010000 replace 1A -1 {} {} + cp1258 \U00010000 strict {} 0 {} {} + cp1258 \U0010FFFF tcl8 1A -1 {} {} + cp1258 \U0010FFFF replace 1A -1 {} {} + cp1258 \U0010FFFF strict {} 0 {} {} +}; # cp1258 + +# +# gb1988 (generated from glibc-GB_1988_80-2.3.3) + +test encoding-convertfrom-ucmCompare-gb1988 {Compare against ICU UCM} -body { + ucmConvertfromMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E} +} -result {} + +test encoding-convertto-ucmCompare-gb1988 {Compare against ICU UCM} -body { + ucmConverttoMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E} +} -result {} + +# gb1988 - invalid byte sequences +lappend encInvalidBytes {*}{ + gb1988 80 tcl8 \U00000080 -1 {} {} + gb1988 80 replace \uFFFD -1 {} {} + gb1988 80 strict {} 0 {} {} + gb1988 81 tcl8 \U00000081 -1 {} {} + gb1988 81 replace \uFFFD -1 {} {} + gb1988 81 strict {} 0 {} {} + gb1988 82 tcl8 \U00000082 -1 {} {} + gb1988 82 replace \uFFFD -1 {} {} + gb1988 82 strict {} 0 {} {} + gb1988 83 tcl8 \U00000083 -1 {} {} + gb1988 83 replace \uFFFD -1 {} {} + gb1988 83 strict {} 0 {} {} + gb1988 84 tcl8 \U00000084 -1 {} {} + gb1988 84 replace \uFFFD -1 {} {} + gb1988 84 strict {} 0 {} {} + gb1988 85 tcl8 \U00000085 -1 {} {} + gb1988 85 replace \uFFFD -1 {} {} + gb1988 85 strict {} 0 {} {} + gb1988 86 tcl8 \U00000086 -1 {} {} + gb1988 86 replace \uFFFD -1 {} {} + gb1988 86 strict {} 0 {} {} + gb1988 87 tcl8 \U00000087 -1 {} {} + gb1988 87 replace \uFFFD -1 {} {} + gb1988 87 strict {} 0 {} {} + gb1988 88 tcl8 \U00000088 -1 {} {} + gb1988 88 replace \uFFFD -1 {} {} + gb1988 88 strict {} 0 {} {} + gb1988 89 tcl8 \U00000089 -1 {} {} + gb1988 89 replace \uFFFD -1 {} {} + gb1988 89 strict {} 0 {} {} + gb1988 8A tcl8 \U0000008A -1 {} {} + gb1988 8A replace \uFFFD -1 {} {} + gb1988 8A strict {} 0 {} {} + gb1988 8B tcl8 \U0000008B -1 {} {} + gb1988 8B replace \uFFFD -1 {} {} + gb1988 8B strict {} 0 {} {} + gb1988 8C tcl8 \U0000008C -1 {} {} + gb1988 8C replace \uFFFD -1 {} {} + gb1988 8C strict {} 0 {} {} + gb1988 8D tcl8 \U0000008D -1 {} {} + gb1988 8D replace \uFFFD -1 {} {} + gb1988 8D strict {} 0 {} {} + gb1988 8E tcl8 \U0000008E -1 {} {} + gb1988 8E replace \uFFFD -1 {} {} + gb1988 8E strict {} 0 {} {} + gb1988 8F tcl8 \U0000008F -1 {} {} + gb1988 8F replace \uFFFD -1 {} {} + gb1988 8F strict {} 0 {} {} + gb1988 90 tcl8 \U00000090 -1 {} {} + gb1988 90 replace \uFFFD -1 {} {} + gb1988 90 strict {} 0 {} {} + gb1988 91 tcl8 \U00000091 -1 {} {} + gb1988 91 replace \uFFFD -1 {} {} + gb1988 91 strict {} 0 {} {} + gb1988 92 tcl8 \U00000092 -1 {} {} + gb1988 92 replace \uFFFD -1 {} {} + gb1988 92 strict {} 0 {} {} + gb1988 93 tcl8 \U00000093 -1 {} {} + gb1988 93 replace \uFFFD -1 {} {} + gb1988 93 strict {} 0 {} {} + gb1988 94 tcl8 \U00000094 -1 {} {} + gb1988 94 replace \uFFFD -1 {} {} + gb1988 94 strict {} 0 {} {} + gb1988 95 tcl8 \U00000095 -1 {} {} + gb1988 95 replace \uFFFD -1 {} {} + gb1988 95 strict {} 0 {} {} + gb1988 96 tcl8 \U00000096 -1 {} {} + gb1988 96 replace \uFFFD -1 {} {} + gb1988 96 strict {} 0 {} {} + gb1988 97 tcl8 \U00000097 -1 {} {} + gb1988 97 replace \uFFFD -1 {} {} + gb1988 97 strict {} 0 {} {} + gb1988 98 tcl8 \U00000098 -1 {} {} + gb1988 98 replace \uFFFD -1 {} {} + gb1988 98 strict {} 0 {} {} + gb1988 99 tcl8 \U00000099 -1 {} {} + gb1988 99 replace \uFFFD -1 {} {} + gb1988 99 strict {} 0 {} {} + gb1988 9A tcl8 \U0000009A -1 {} {} + gb1988 9A replace \uFFFD -1 {} {} + gb1988 9A strict {} 0 {} {} + gb1988 9B tcl8 \U0000009B -1 {} {} + gb1988 9B replace \uFFFD -1 {} {} + gb1988 9B strict {} 0 {} {} + gb1988 9C tcl8 \U0000009C -1 {} {} + gb1988 9C replace \uFFFD -1 {} {} + gb1988 9C strict {} 0 {} {} + gb1988 9D tcl8 \U0000009D -1 {} {} + gb1988 9D replace \uFFFD -1 {} {} + gb1988 9D strict {} 0 {} {} + gb1988 9E tcl8 \U0000009E -1 {} {} + gb1988 9E replace \uFFFD -1 {} {} + gb1988 9E strict {} 0 {} {} + gb1988 9F tcl8 \U0000009F -1 {} {} + gb1988 9F replace \uFFFD -1 {} {} + gb1988 9F strict {} 0 {} {} + gb1988 A0 tcl8 \U000000A0 -1 {} {} + gb1988 A0 replace \uFFFD -1 {} {} + gb1988 A0 strict {} 0 {} {} + gb1988 A1 tcl8 \U000000A1 -1 {} {} + gb1988 A1 replace \uFFFD -1 {} {} + gb1988 A1 strict {} 0 {} {} + gb1988 A2 tcl8 \U000000A2 -1 {} {} + gb1988 A2 replace \uFFFD -1 {} {} + gb1988 A2 strict {} 0 {} {} + gb1988 A3 tcl8 \U000000A3 -1 {} {} + gb1988 A3 replace \uFFFD -1 {} {} + gb1988 A3 strict {} 0 {} {} + gb1988 A4 tcl8 \U000000A4 -1 {} {} + gb1988 A4 replace \uFFFD -1 {} {} + gb1988 A4 strict {} 0 {} {} + gb1988 A5 tcl8 \U000000A5 -1 {} {} + gb1988 A5 replace \uFFFD -1 {} {} + gb1988 A5 strict {} 0 {} {} + gb1988 A6 tcl8 \U000000A6 -1 {} {} + gb1988 A6 replace \uFFFD -1 {} {} + gb1988 A6 strict {} 0 {} {} + gb1988 A7 tcl8 \U000000A7 -1 {} {} + gb1988 A7 replace \uFFFD -1 {} {} + gb1988 A7 strict {} 0 {} {} + gb1988 A8 tcl8 \U000000A8 -1 {} {} + gb1988 A8 replace \uFFFD -1 {} {} + gb1988 A8 strict {} 0 {} {} + gb1988 A9 tcl8 \U000000A9 -1 {} {} + gb1988 A9 replace \uFFFD -1 {} {} + gb1988 A9 strict {} 0 {} {} + gb1988 AA tcl8 \U000000AA -1 {} {} + gb1988 AA replace \uFFFD -1 {} {} + gb1988 AA strict {} 0 {} {} + gb1988 AB tcl8 \U000000AB -1 {} {} + gb1988 AB replace \uFFFD -1 {} {} + gb1988 AB strict {} 0 {} {} + gb1988 AC tcl8 \U000000AC -1 {} {} + gb1988 AC replace \uFFFD -1 {} {} + gb1988 AC strict {} 0 {} {} + gb1988 AD tcl8 \U000000AD -1 {} {} + gb1988 AD replace \uFFFD -1 {} {} + gb1988 AD strict {} 0 {} {} + gb1988 AE tcl8 \U000000AE -1 {} {} + gb1988 AE replace \uFFFD -1 {} {} + gb1988 AE strict {} 0 {} {} + gb1988 AF tcl8 \U000000AF -1 {} {} + gb1988 AF replace \uFFFD -1 {} {} + gb1988 AF strict {} 0 {} {} + gb1988 B0 tcl8 \U000000B0 -1 {} {} + gb1988 B0 replace \uFFFD -1 {} {} + gb1988 B0 strict {} 0 {} {} + gb1988 B1 tcl8 \U000000B1 -1 {} {} + gb1988 B1 replace \uFFFD -1 {} {} + gb1988 B1 strict {} 0 {} {} + gb1988 B2 tcl8 \U000000B2 -1 {} {} + gb1988 B2 replace \uFFFD -1 {} {} + gb1988 B2 strict {} 0 {} {} + gb1988 B3 tcl8 \U000000B3 -1 {} {} + gb1988 B3 replace \uFFFD -1 {} {} + gb1988 B3 strict {} 0 {} {} + gb1988 B4 tcl8 \U000000B4 -1 {} {} + gb1988 B4 replace \uFFFD -1 {} {} + gb1988 B4 strict {} 0 {} {} + gb1988 B5 tcl8 \U000000B5 -1 {} {} + gb1988 B5 replace \uFFFD -1 {} {} + gb1988 B5 strict {} 0 {} {} + gb1988 B6 tcl8 \U000000B6 -1 {} {} + gb1988 B6 replace \uFFFD -1 {} {} + gb1988 B6 strict {} 0 {} {} + gb1988 B7 tcl8 \U000000B7 -1 {} {} + gb1988 B7 replace \uFFFD -1 {} {} + gb1988 B7 strict {} 0 {} {} + gb1988 B8 tcl8 \U000000B8 -1 {} {} + gb1988 B8 replace \uFFFD -1 {} {} + gb1988 B8 strict {} 0 {} {} + gb1988 B9 tcl8 \U000000B9 -1 {} {} + gb1988 B9 replace \uFFFD -1 {} {} + gb1988 B9 strict {} 0 {} {} + gb1988 BA tcl8 \U000000BA -1 {} {} + gb1988 BA replace \uFFFD -1 {} {} + gb1988 BA strict {} 0 {} {} + gb1988 BB tcl8 \U000000BB -1 {} {} + gb1988 BB replace \uFFFD -1 {} {} + gb1988 BB strict {} 0 {} {} + gb1988 BC tcl8 \U000000BC -1 {} {} + gb1988 BC replace \uFFFD -1 {} {} + gb1988 BC strict {} 0 {} {} + gb1988 BD tcl8 \U000000BD -1 {} {} + gb1988 BD replace \uFFFD -1 {} {} + gb1988 BD strict {} 0 {} {} + gb1988 BE tcl8 \U000000BE -1 {} {} + gb1988 BE replace \uFFFD -1 {} {} + gb1988 BE strict {} 0 {} {} + gb1988 BF tcl8 \U000000BF -1 {} {} + gb1988 BF replace \uFFFD -1 {} {} + gb1988 BF strict {} 0 {} {} + gb1988 C0 tcl8 \U000000C0 -1 {} {} + gb1988 C0 replace \uFFFD -1 {} {} + gb1988 C0 strict {} 0 {} {} + gb1988 C1 tcl8 \U000000C1 -1 {} {} + gb1988 C1 replace \uFFFD -1 {} {} + gb1988 C1 strict {} 0 {} {} + gb1988 C2 tcl8 \U000000C2 -1 {} {} + gb1988 C2 replace \uFFFD -1 {} {} + gb1988 C2 strict {} 0 {} {} + gb1988 C3 tcl8 \U000000C3 -1 {} {} + gb1988 C3 replace \uFFFD -1 {} {} + gb1988 C3 strict {} 0 {} {} + gb1988 C4 tcl8 \U000000C4 -1 {} {} + gb1988 C4 replace \uFFFD -1 {} {} + gb1988 C4 strict {} 0 {} {} + gb1988 C5 tcl8 \U000000C5 -1 {} {} + gb1988 C5 replace \uFFFD -1 {} {} + gb1988 C5 strict {} 0 {} {} + gb1988 C6 tcl8 \U000000C6 -1 {} {} + gb1988 C6 replace \uFFFD -1 {} {} + gb1988 C6 strict {} 0 {} {} + gb1988 C7 tcl8 \U000000C7 -1 {} {} + gb1988 C7 replace \uFFFD -1 {} {} + gb1988 C7 strict {} 0 {} {} + gb1988 C8 tcl8 \U000000C8 -1 {} {} + gb1988 C8 replace \uFFFD -1 {} {} + gb1988 C8 strict {} 0 {} {} + gb1988 C9 tcl8 \U000000C9 -1 {} {} + gb1988 C9 replace \uFFFD -1 {} {} + gb1988 C9 strict {} 0 {} {} + gb1988 CA tcl8 \U000000CA -1 {} {} + gb1988 CA replace \uFFFD -1 {} {} + gb1988 CA strict {} 0 {} {} + gb1988 CB tcl8 \U000000CB -1 {} {} + gb1988 CB replace \uFFFD -1 {} {} + gb1988 CB strict {} 0 {} {} + gb1988 CC tcl8 \U000000CC -1 {} {} + gb1988 CC replace \uFFFD -1 {} {} + gb1988 CC strict {} 0 {} {} + gb1988 CD tcl8 \U000000CD -1 {} {} + gb1988 CD replace \uFFFD -1 {} {} + gb1988 CD strict {} 0 {} {} + gb1988 CE tcl8 \U000000CE -1 {} {} + gb1988 CE replace \uFFFD -1 {} {} + gb1988 CE strict {} 0 {} {} + gb1988 CF tcl8 \U000000CF -1 {} {} + gb1988 CF replace \uFFFD -1 {} {} + gb1988 CF strict {} 0 {} {} + gb1988 D0 tcl8 \U000000D0 -1 {} {} + gb1988 D0 replace \uFFFD -1 {} {} + gb1988 D0 strict {} 0 {} {} + gb1988 D1 tcl8 \U000000D1 -1 {} {} + gb1988 D1 replace \uFFFD -1 {} {} + gb1988 D1 strict {} 0 {} {} + gb1988 D2 tcl8 \U000000D2 -1 {} {} + gb1988 D2 replace \uFFFD -1 {} {} + gb1988 D2 strict {} 0 {} {} + gb1988 D3 tcl8 \U000000D3 -1 {} {} + gb1988 D3 replace \uFFFD -1 {} {} + gb1988 D3 strict {} 0 {} {} + gb1988 D4 tcl8 \U000000D4 -1 {} {} + gb1988 D4 replace \uFFFD -1 {} {} + gb1988 D4 strict {} 0 {} {} + gb1988 D5 tcl8 \U000000D5 -1 {} {} + gb1988 D5 replace \uFFFD -1 {} {} + gb1988 D5 strict {} 0 {} {} + gb1988 D6 tcl8 \U000000D6 -1 {} {} + gb1988 D6 replace \uFFFD -1 {} {} + gb1988 D6 strict {} 0 {} {} + gb1988 D7 tcl8 \U000000D7 -1 {} {} + gb1988 D7 replace \uFFFD -1 {} {} + gb1988 D7 strict {} 0 {} {} + gb1988 D8 tcl8 \U000000D8 -1 {} {} + gb1988 D8 replace \uFFFD -1 {} {} + gb1988 D8 strict {} 0 {} {} + gb1988 D9 tcl8 \U000000D9 -1 {} {} + gb1988 D9 replace \uFFFD -1 {} {} + gb1988 D9 strict {} 0 {} {} + gb1988 DA tcl8 \U000000DA -1 {} {} + gb1988 DA replace \uFFFD -1 {} {} + gb1988 DA strict {} 0 {} {} + gb1988 DB tcl8 \U000000DB -1 {} {} + gb1988 DB replace \uFFFD -1 {} {} + gb1988 DB strict {} 0 {} {} + gb1988 DC tcl8 \U000000DC -1 {} {} + gb1988 DC replace \uFFFD -1 {} {} + gb1988 DC strict {} 0 {} {} + gb1988 DD tcl8 \U000000DD -1 {} {} + gb1988 DD replace \uFFFD -1 {} {} + gb1988 DD strict {} 0 {} {} + gb1988 DE tcl8 \U000000DE -1 {} {} + gb1988 DE replace \uFFFD -1 {} {} + gb1988 DE strict {} 0 {} {} + gb1988 DF tcl8 \U000000DF -1 {} {} + gb1988 DF replace \uFFFD -1 {} {} + gb1988 DF strict {} 0 {} {} + gb1988 E0 tcl8 \U000000E0 -1 {} {} + gb1988 E0 replace \uFFFD -1 {} {} + gb1988 E0 strict {} 0 {} {} + gb1988 E1 tcl8 \U000000E1 -1 {} {} + gb1988 E1 replace \uFFFD -1 {} {} + gb1988 E1 strict {} 0 {} {} + gb1988 E2 tcl8 \U000000E2 -1 {} {} + gb1988 E2 replace \uFFFD -1 {} {} + gb1988 E2 strict {} 0 {} {} + gb1988 E3 tcl8 \U000000E3 -1 {} {} + gb1988 E3 replace \uFFFD -1 {} {} + gb1988 E3 strict {} 0 {} {} + gb1988 E4 tcl8 \U000000E4 -1 {} {} + gb1988 E4 replace \uFFFD -1 {} {} + gb1988 E4 strict {} 0 {} {} + gb1988 E5 tcl8 \U000000E5 -1 {} {} + gb1988 E5 replace \uFFFD -1 {} {} + gb1988 E5 strict {} 0 {} {} + gb1988 E6 tcl8 \U000000E6 -1 {} {} + gb1988 E6 replace \uFFFD -1 {} {} + gb1988 E6 strict {} 0 {} {} + gb1988 E7 tcl8 \U000000E7 -1 {} {} + gb1988 E7 replace \uFFFD -1 {} {} + gb1988 E7 strict {} 0 {} {} + gb1988 E8 tcl8 \U000000E8 -1 {} {} + gb1988 E8 replace \uFFFD -1 {} {} + gb1988 E8 strict {} 0 {} {} + gb1988 E9 tcl8 \U000000E9 -1 {} {} + gb1988 E9 replace \uFFFD -1 {} {} + gb1988 E9 strict {} 0 {} {} + gb1988 EA tcl8 \U000000EA -1 {} {} + gb1988 EA replace \uFFFD -1 {} {} + gb1988 EA strict {} 0 {} {} + gb1988 EB tcl8 \U000000EB -1 {} {} + gb1988 EB replace \uFFFD -1 {} {} + gb1988 EB strict {} 0 {} {} + gb1988 EC tcl8 \U000000EC -1 {} {} + gb1988 EC replace \uFFFD -1 {} {} + gb1988 EC strict {} 0 {} {} + gb1988 ED tcl8 \U000000ED -1 {} {} + gb1988 ED replace \uFFFD -1 {} {} + gb1988 ED strict {} 0 {} {} + gb1988 EE tcl8 \U000000EE -1 {} {} + gb1988 EE replace \uFFFD -1 {} {} + gb1988 EE strict {} 0 {} {} + gb1988 EF tcl8 \U000000EF -1 {} {} + gb1988 EF replace \uFFFD -1 {} {} + gb1988 EF strict {} 0 {} {} + gb1988 F0 tcl8 \U000000F0 -1 {} {} + gb1988 F0 replace \uFFFD -1 {} {} + gb1988 F0 strict {} 0 {} {} + gb1988 F1 tcl8 \U000000F1 -1 {} {} + gb1988 F1 replace \uFFFD -1 {} {} + gb1988 F1 strict {} 0 {} {} + gb1988 F2 tcl8 \U000000F2 -1 {} {} + gb1988 F2 replace \uFFFD -1 {} {} + gb1988 F2 strict {} 0 {} {} + gb1988 F3 tcl8 \U000000F3 -1 {} {} + gb1988 F3 replace \uFFFD -1 {} {} + gb1988 F3 strict {} 0 {} {} + gb1988 F4 tcl8 \U000000F4 -1 {} {} + gb1988 F4 replace \uFFFD -1 {} {} + gb1988 F4 strict {} 0 {} {} + gb1988 F5 tcl8 \U000000F5 -1 {} {} + gb1988 F5 replace \uFFFD -1 {} {} + gb1988 F5 strict {} 0 {} {} + gb1988 F6 tcl8 \U000000F6 -1 {} {} + gb1988 F6 replace \uFFFD -1 {} {} + gb1988 F6 strict {} 0 {} {} + gb1988 F7 tcl8 \U000000F7 -1 {} {} + gb1988 F7 replace \uFFFD -1 {} {} + gb1988 F7 strict {} 0 {} {} + gb1988 F8 tcl8 \U000000F8 -1 {} {} + gb1988 F8 replace \uFFFD -1 {} {} + gb1988 F8 strict {} 0 {} {} + gb1988 F9 tcl8 \U000000F9 -1 {} {} + gb1988 F9 replace \uFFFD -1 {} {} + gb1988 F9 strict {} 0 {} {} + gb1988 FA tcl8 \U000000FA -1 {} {} + gb1988 FA replace \uFFFD -1 {} {} + gb1988 FA strict {} 0 {} {} + gb1988 FB tcl8 \U000000FB -1 {} {} + gb1988 FB replace \uFFFD -1 {} {} + gb1988 FB strict {} 0 {} {} + gb1988 FC tcl8 \U000000FC -1 {} {} + gb1988 FC replace \uFFFD -1 {} {} + gb1988 FC strict {} 0 {} {} + gb1988 FD tcl8 \U000000FD -1 {} {} + gb1988 FD replace \uFFFD -1 {} {} + gb1988 FD strict {} 0 {} {} + gb1988 FE tcl8 \U000000FE -1 {} {} + gb1988 FE replace \uFFFD -1 {} {} + gb1988 FE strict {} 0 {} {} + gb1988 FF tcl8 \U000000FF -1 {} {} + gb1988 FF replace \uFFFD -1 {} {} + gb1988 FF strict {} 0 {} {} +}; # gb1988 + +# gb1988 - invalid byte sequences +lappend encUnencodableStrings {*}{ + gb1988 \U00000024 tcl8 1A -1 {} {} + gb1988 \U00000024 replace 1A -1 {} {} + gb1988 \U00000024 strict {} 0 {} {} + gb1988 \U00000400 tcl8 1A -1 {} {} + gb1988 \U00000400 replace 1A -1 {} {} + gb1988 \U00000400 strict {} 0 {} {} + gb1988 \U0000D800 tcl8 1A -1 {} {} + gb1988 \U0000D800 replace 1A -1 {} {} + gb1988 \U0000D800 strict {} 0 {} {} + gb1988 \U0000DC00 tcl8 1A -1 {} {} + gb1988 \U0000DC00 replace 1A -1 {} {} + gb1988 \U0000DC00 strict {} 0 {} {} + gb1988 \U00010000 tcl8 1A -1 {} {} + gb1988 \U00010000 replace 1A -1 {} {} + gb1988 \U00010000 strict {} 0 {} {} + gb1988 \U0010FFFF tcl8 1A -1 {} {} + gb1988 \U0010FFFF replace 1A -1 {} {} + gb1988 \U0010FFFF strict {} 0 {} {} +}; # gb1988 + +# +# iso8859-1 (generated from glibc-ISO_8859_1-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-1 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-1 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF} +} -result {} + +# iso8859-1 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-1 + +# iso8859-1 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-1 \U00000400 tcl8 1A -1 {} {} + iso8859-1 \U00000400 replace 1A -1 {} {} + iso8859-1 \U00000400 strict {} 0 {} {} + iso8859-1 \U0000D800 tcl8 1A -1 {} {} + iso8859-1 \U0000D800 replace 1A -1 {} {} + iso8859-1 \U0000D800 strict {} 0 {} {} + iso8859-1 \U0000DC00 tcl8 1A -1 {} {} + iso8859-1 \U0000DC00 replace 1A -1 {} {} + iso8859-1 \U0000DC00 strict {} 0 {} {} + iso8859-1 \U00010000 tcl8 1A -1 {} {} + iso8859-1 \U00010000 replace 1A -1 {} {} + iso8859-1 \U00010000 strict {} 0 {} {} + iso8859-1 \U0010FFFF tcl8 1A -1 {} {} + iso8859-1 \U0010FFFF replace 1A -1 {} {} + iso8859-1 \U0010FFFF strict {} 0 {} {} +}; # iso8859-1 + +# +# iso8859-2 (generated from glibc-ISO_8859_2-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-2 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-2 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD} +} -result {} + +# iso8859-2 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-2 + +# iso8859-2 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-2 \U000000A1 tcl8 1A -1 {} {} + iso8859-2 \U000000A1 replace 1A -1 {} {} + iso8859-2 \U000000A1 strict {} 0 {} {} + iso8859-2 \U00000400 tcl8 1A -1 {} {} + iso8859-2 \U00000400 replace 1A -1 {} {} + iso8859-2 \U00000400 strict {} 0 {} {} + iso8859-2 \U0000D800 tcl8 1A -1 {} {} + iso8859-2 \U0000D800 replace 1A -1 {} {} + iso8859-2 \U0000D800 strict {} 0 {} {} + iso8859-2 \U0000DC00 tcl8 1A -1 {} {} + iso8859-2 \U0000DC00 replace 1A -1 {} {} + iso8859-2 \U0000DC00 strict {} 0 {} {} + iso8859-2 \U00010000 tcl8 1A -1 {} {} + iso8859-2 \U00010000 replace 1A -1 {} {} + iso8859-2 \U00010000 strict {} 0 {} {} + iso8859-2 \U0010FFFF tcl8 1A -1 {} {} + iso8859-2 \U0010FFFF replace 1A -1 {} {} + iso8859-2 \U0010FFFF strict {} 0 {} {} +}; # iso8859-2 + +# +# iso8859-3 (generated from glibc-ISO_8859_3-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-3 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-3 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF} +} -result {} + +# iso8859-3 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-3 A5 tcl8 \U000000A5 -1 {} {} + iso8859-3 A5 replace \uFFFD -1 {} {} + iso8859-3 A5 strict {} 0 {} {} + iso8859-3 AE tcl8 \U000000AE -1 {} {} + iso8859-3 AE replace \uFFFD -1 {} {} + iso8859-3 AE strict {} 0 {} {} + iso8859-3 BE tcl8 \U000000BE -1 {} {} + iso8859-3 BE replace \uFFFD -1 {} {} + iso8859-3 BE strict {} 0 {} {} + iso8859-3 C3 tcl8 \U000000C3 -1 {} {} + iso8859-3 C3 replace \uFFFD -1 {} {} + iso8859-3 C3 strict {} 0 {} {} + iso8859-3 D0 tcl8 \U000000D0 -1 {} {} + iso8859-3 D0 replace \uFFFD -1 {} {} + iso8859-3 D0 strict {} 0 {} {} + iso8859-3 E3 tcl8 \U000000E3 -1 {} {} + iso8859-3 E3 replace \uFFFD -1 {} {} + iso8859-3 E3 strict {} 0 {} {} + iso8859-3 F0 tcl8 \U000000F0 -1 {} {} + iso8859-3 F0 replace \uFFFD -1 {} {} + iso8859-3 F0 strict {} 0 {} {} +}; # iso8859-3 + +# iso8859-3 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-3 \U000000A1 tcl8 1A -1 {} {} + iso8859-3 \U000000A1 replace 1A -1 {} {} + iso8859-3 \U000000A1 strict {} 0 {} {} + iso8859-3 \U00000400 tcl8 1A -1 {} {} + iso8859-3 \U00000400 replace 1A -1 {} {} + iso8859-3 \U00000400 strict {} 0 {} {} + iso8859-3 \U0000D800 tcl8 1A -1 {} {} + iso8859-3 \U0000D800 replace 1A -1 {} {} + iso8859-3 \U0000D800 strict {} 0 {} {} + iso8859-3 \U0000DC00 tcl8 1A -1 {} {} + iso8859-3 \U0000DC00 replace 1A -1 {} {} + iso8859-3 \U0000DC00 strict {} 0 {} {} + iso8859-3 \U00010000 tcl8 1A -1 {} {} + iso8859-3 \U00010000 replace 1A -1 {} {} + iso8859-3 \U00010000 strict {} 0 {} {} + iso8859-3 \U0010FFFF tcl8 1A -1 {} {} + iso8859-3 \U0010FFFF replace 1A -1 {} {} + iso8859-3 \U0010FFFF strict {} 0 {} {} +}; # iso8859-3 + +# +# iso8859-4 (generated from glibc-ISO_8859_4-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-4 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-4 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2} +} -result {} + +# iso8859-4 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-4 + +# iso8859-4 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-4 \U000000A1 tcl8 1A -1 {} {} + iso8859-4 \U000000A1 replace 1A -1 {} {} + iso8859-4 \U000000A1 strict {} 0 {} {} + iso8859-4 \U00000400 tcl8 1A -1 {} {} + iso8859-4 \U00000400 replace 1A -1 {} {} + iso8859-4 \U00000400 strict {} 0 {} {} + iso8859-4 \U0000D800 tcl8 1A -1 {} {} + iso8859-4 \U0000D800 replace 1A -1 {} {} + iso8859-4 \U0000D800 strict {} 0 {} {} + iso8859-4 \U0000DC00 tcl8 1A -1 {} {} + iso8859-4 \U0000DC00 replace 1A -1 {} {} + iso8859-4 \U0000DC00 strict {} 0 {} {} + iso8859-4 \U00010000 tcl8 1A -1 {} {} + iso8859-4 \U00010000 replace 1A -1 {} {} + iso8859-4 \U00010000 strict {} 0 {} {} + iso8859-4 \U0010FFFF tcl8 1A -1 {} {} + iso8859-4 \U0010FFFF replace 1A -1 {} {} + iso8859-4 \U0010FFFF strict {} 0 {} {} +}; # iso8859-4 + +# +# iso8859-5 (generated from glibc-ISO_8859_5-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-5 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-5 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0} +} -result {} + +# iso8859-5 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-5 + +# iso8859-5 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-5 \U000000A1 tcl8 1A -1 {} {} + iso8859-5 \U000000A1 replace 1A -1 {} {} + iso8859-5 \U000000A1 strict {} 0 {} {} + iso8859-5 \U00000400 tcl8 1A -1 {} {} + iso8859-5 \U00000400 replace 1A -1 {} {} + iso8859-5 \U00000400 strict {} 0 {} {} + iso8859-5 \U0000D800 tcl8 1A -1 {} {} + iso8859-5 \U0000D800 replace 1A -1 {} {} + iso8859-5 \U0000D800 strict {} 0 {} {} + iso8859-5 \U0000DC00 tcl8 1A -1 {} {} + iso8859-5 \U0000DC00 replace 1A -1 {} {} + iso8859-5 \U0000DC00 strict {} 0 {} {} + iso8859-5 \U00010000 tcl8 1A -1 {} {} + iso8859-5 \U00010000 replace 1A -1 {} {} + iso8859-5 \U00010000 strict {} 0 {} {} + iso8859-5 \U0010FFFF tcl8 1A -1 {} {} + iso8859-5 \U0010FFFF replace 1A -1 {} {} + iso8859-5 \U0010FFFF strict {} 0 {} {} +}; # iso8859-5 + +# +# iso8859-6 (generated from glibc-ISO_8859_6-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-6 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-6 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2} +} -result {} + +# iso8859-6 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-6 A1 tcl8 \U000000A1 -1 {} {} + iso8859-6 A1 replace \uFFFD -1 {} {} + iso8859-6 A1 strict {} 0 {} {} + iso8859-6 A2 tcl8 \U000000A2 -1 {} {} + iso8859-6 A2 replace \uFFFD -1 {} {} + iso8859-6 A2 strict {} 0 {} {} + iso8859-6 A3 tcl8 \U000000A3 -1 {} {} + iso8859-6 A3 replace \uFFFD -1 {} {} + iso8859-6 A3 strict {} 0 {} {} + iso8859-6 A5 tcl8 \U000000A5 -1 {} {} + iso8859-6 A5 replace \uFFFD -1 {} {} + iso8859-6 A5 strict {} 0 {} {} + iso8859-6 A6 tcl8 \U000000A6 -1 {} {} + iso8859-6 A6 replace \uFFFD -1 {} {} + iso8859-6 A6 strict {} 0 {} {} + iso8859-6 A7 tcl8 \U000000A7 -1 {} {} + iso8859-6 A7 replace \uFFFD -1 {} {} + iso8859-6 A7 strict {} 0 {} {} + iso8859-6 A8 tcl8 \U000000A8 -1 {} {} + iso8859-6 A8 replace \uFFFD -1 {} {} + iso8859-6 A8 strict {} 0 {} {} + iso8859-6 A9 tcl8 \U000000A9 -1 {} {} + iso8859-6 A9 replace \uFFFD -1 {} {} + iso8859-6 A9 strict {} 0 {} {} + iso8859-6 AA tcl8 \U000000AA -1 {} {} + iso8859-6 AA replace \uFFFD -1 {} {} + iso8859-6 AA strict {} 0 {} {} + iso8859-6 AB tcl8 \U000000AB -1 {} {} + iso8859-6 AB replace \uFFFD -1 {} {} + iso8859-6 AB strict {} 0 {} {} + iso8859-6 AE tcl8 \U000000AE -1 {} {} + iso8859-6 AE replace \uFFFD -1 {} {} + iso8859-6 AE strict {} 0 {} {} + iso8859-6 AF tcl8 \U000000AF -1 {} {} + iso8859-6 AF replace \uFFFD -1 {} {} + iso8859-6 AF strict {} 0 {} {} + iso8859-6 B0 tcl8 \U000000B0 -1 {} {} + iso8859-6 B0 replace \uFFFD -1 {} {} + iso8859-6 B0 strict {} 0 {} {} + iso8859-6 B1 tcl8 \U000000B1 -1 {} {} + iso8859-6 B1 replace \uFFFD -1 {} {} + iso8859-6 B1 strict {} 0 {} {} + iso8859-6 B2 tcl8 \U000000B2 -1 {} {} + iso8859-6 B2 replace \uFFFD -1 {} {} + iso8859-6 B2 strict {} 0 {} {} + iso8859-6 B3 tcl8 \U000000B3 -1 {} {} + iso8859-6 B3 replace \uFFFD -1 {} {} + iso8859-6 B3 strict {} 0 {} {} + iso8859-6 B4 tcl8 \U000000B4 -1 {} {} + iso8859-6 B4 replace \uFFFD -1 {} {} + iso8859-6 B4 strict {} 0 {} {} + iso8859-6 B5 tcl8 \U000000B5 -1 {} {} + iso8859-6 B5 replace \uFFFD -1 {} {} + iso8859-6 B5 strict {} 0 {} {} + iso8859-6 B6 tcl8 \U000000B6 -1 {} {} + iso8859-6 B6 replace \uFFFD -1 {} {} + iso8859-6 B6 strict {} 0 {} {} + iso8859-6 B7 tcl8 \U000000B7 -1 {} {} + iso8859-6 B7 replace \uFFFD -1 {} {} + iso8859-6 B7 strict {} 0 {} {} + iso8859-6 B8 tcl8 \U000000B8 -1 {} {} + iso8859-6 B8 replace \uFFFD -1 {} {} + iso8859-6 B8 strict {} 0 {} {} + iso8859-6 B9 tcl8 \U000000B9 -1 {} {} + iso8859-6 B9 replace \uFFFD -1 {} {} + iso8859-6 B9 strict {} 0 {} {} + iso8859-6 BA tcl8 \U000000BA -1 {} {} + iso8859-6 BA replace \uFFFD -1 {} {} + iso8859-6 BA strict {} 0 {} {} + iso8859-6 BC tcl8 \U000000BC -1 {} {} + iso8859-6 BC replace \uFFFD -1 {} {} + iso8859-6 BC strict {} 0 {} {} + iso8859-6 BD tcl8 \U000000BD -1 {} {} + iso8859-6 BD replace \uFFFD -1 {} {} + iso8859-6 BD strict {} 0 {} {} + iso8859-6 BE tcl8 \U000000BE -1 {} {} + iso8859-6 BE replace \uFFFD -1 {} {} + iso8859-6 BE strict {} 0 {} {} + iso8859-6 C0 tcl8 \U000000C0 -1 {} {} + iso8859-6 C0 replace \uFFFD -1 {} {} + iso8859-6 C0 strict {} 0 {} {} + iso8859-6 DB tcl8 \U000000DB -1 {} {} + iso8859-6 DB replace \uFFFD -1 {} {} + iso8859-6 DB strict {} 0 {} {} + iso8859-6 DC tcl8 \U000000DC -1 {} {} + iso8859-6 DC replace \uFFFD -1 {} {} + iso8859-6 DC strict {} 0 {} {} + iso8859-6 DD tcl8 \U000000DD -1 {} {} + iso8859-6 DD replace \uFFFD -1 {} {} + iso8859-6 DD strict {} 0 {} {} + iso8859-6 DE tcl8 \U000000DE -1 {} {} + iso8859-6 DE replace \uFFFD -1 {} {} + iso8859-6 DE strict {} 0 {} {} + iso8859-6 DF tcl8 \U000000DF -1 {} {} + iso8859-6 DF replace \uFFFD -1 {} {} + iso8859-6 DF strict {} 0 {} {} + iso8859-6 F3 tcl8 \U000000F3 -1 {} {} + iso8859-6 F3 replace \uFFFD -1 {} {} + iso8859-6 F3 strict {} 0 {} {} + iso8859-6 F4 tcl8 \U000000F4 -1 {} {} + iso8859-6 F4 replace \uFFFD -1 {} {} + iso8859-6 F4 strict {} 0 {} {} + iso8859-6 F5 tcl8 \U000000F5 -1 {} {} + iso8859-6 F5 replace \uFFFD -1 {} {} + iso8859-6 F5 strict {} 0 {} {} + iso8859-6 F6 tcl8 \U000000F6 -1 {} {} + iso8859-6 F6 replace \uFFFD -1 {} {} + iso8859-6 F6 strict {} 0 {} {} + iso8859-6 F7 tcl8 \U000000F7 -1 {} {} + iso8859-6 F7 replace \uFFFD -1 {} {} + iso8859-6 F7 strict {} 0 {} {} + iso8859-6 F8 tcl8 \U000000F8 -1 {} {} + iso8859-6 F8 replace \uFFFD -1 {} {} + iso8859-6 F8 strict {} 0 {} {} + iso8859-6 F9 tcl8 \U000000F9 -1 {} {} + iso8859-6 F9 replace \uFFFD -1 {} {} + iso8859-6 F9 strict {} 0 {} {} + iso8859-6 FA tcl8 \U000000FA -1 {} {} + iso8859-6 FA replace \uFFFD -1 {} {} + iso8859-6 FA strict {} 0 {} {} + iso8859-6 FB tcl8 \U000000FB -1 {} {} + iso8859-6 FB replace \uFFFD -1 {} {} + iso8859-6 FB strict {} 0 {} {} + iso8859-6 FC tcl8 \U000000FC -1 {} {} + iso8859-6 FC replace \uFFFD -1 {} {} + iso8859-6 FC strict {} 0 {} {} + iso8859-6 FD tcl8 \U000000FD -1 {} {} + iso8859-6 FD replace \uFFFD -1 {} {} + iso8859-6 FD strict {} 0 {} {} + iso8859-6 FE tcl8 \U000000FE -1 {} {} + iso8859-6 FE replace \uFFFD -1 {} {} + iso8859-6 FE strict {} 0 {} {} + iso8859-6 FF tcl8 \U000000FF -1 {} {} + iso8859-6 FF replace \uFFFD -1 {} {} + iso8859-6 FF strict {} 0 {} {} +}; # iso8859-6 + +# iso8859-6 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-6 \U000000A1 tcl8 1A -1 {} {} + iso8859-6 \U000000A1 replace 1A -1 {} {} + iso8859-6 \U000000A1 strict {} 0 {} {} + iso8859-6 \U00000400 tcl8 1A -1 {} {} + iso8859-6 \U00000400 replace 1A -1 {} {} + iso8859-6 \U00000400 strict {} 0 {} {} + iso8859-6 \U0000D800 tcl8 1A -1 {} {} + iso8859-6 \U0000D800 replace 1A -1 {} {} + iso8859-6 \U0000D800 strict {} 0 {} {} + iso8859-6 \U0000DC00 tcl8 1A -1 {} {} + iso8859-6 \U0000DC00 replace 1A -1 {} {} + iso8859-6 \U0000DC00 strict {} 0 {} {} + iso8859-6 \U00010000 tcl8 1A -1 {} {} + iso8859-6 \U00010000 replace 1A -1 {} {} + iso8859-6 \U00010000 strict {} 0 {} {} + iso8859-6 \U0010FFFF tcl8 1A -1 {} {} + iso8859-6 \U0010FFFF replace 1A -1 {} {} + iso8859-6 \U0010FFFF strict {} 0 {} {} +}; # iso8859-6 + +# +# iso8859-7 (generated from glibc-ISO_8859_7-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-7 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-7 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5} +} -result {} + +# iso8859-7 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-7 AE tcl8 \U000000AE -1 {} {} + iso8859-7 AE replace \uFFFD -1 {} {} + iso8859-7 AE strict {} 0 {} {} + iso8859-7 D2 tcl8 \U000000D2 -1 {} {} + iso8859-7 D2 replace \uFFFD -1 {} {} + iso8859-7 D2 strict {} 0 {} {} + iso8859-7 FF tcl8 \U000000FF -1 {} {} + iso8859-7 FF replace \uFFFD -1 {} {} + iso8859-7 FF strict {} 0 {} {} +}; # iso8859-7 + +# iso8859-7 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-7 \U000000A1 tcl8 1A -1 {} {} + iso8859-7 \U000000A1 replace 1A -1 {} {} + iso8859-7 \U000000A1 strict {} 0 {} {} + iso8859-7 \U00000400 tcl8 1A -1 {} {} + iso8859-7 \U00000400 replace 1A -1 {} {} + iso8859-7 \U00000400 strict {} 0 {} {} + iso8859-7 \U0000D800 tcl8 1A -1 {} {} + iso8859-7 \U0000D800 replace 1A -1 {} {} + iso8859-7 \U0000D800 strict {} 0 {} {} + iso8859-7 \U0000DC00 tcl8 1A -1 {} {} + iso8859-7 \U0000DC00 replace 1A -1 {} {} + iso8859-7 \U0000DC00 strict {} 0 {} {} + iso8859-7 \U00010000 tcl8 1A -1 {} {} + iso8859-7 \U00010000 replace 1A -1 {} {} + iso8859-7 \U00010000 strict {} 0 {} {} + iso8859-7 \U0010FFFF tcl8 1A -1 {} {} + iso8859-7 \U0010FFFF replace 1A -1 {} {} + iso8859-7 \U0010FFFF strict {} 0 {} {} +}; # iso8859-7 + +# +# iso8859-8 (generated from glibc-ISO_8859_8-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-8 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-8 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF} +} -result {} + +# iso8859-8 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-8 A1 tcl8 \U000000A1 -1 {} {} + iso8859-8 A1 replace \uFFFD -1 {} {} + iso8859-8 A1 strict {} 0 {} {} + iso8859-8 BF tcl8 \U000000BF -1 {} {} + iso8859-8 BF replace \uFFFD -1 {} {} + iso8859-8 BF strict {} 0 {} {} + iso8859-8 C0 tcl8 \U000000C0 -1 {} {} + iso8859-8 C0 replace \uFFFD -1 {} {} + iso8859-8 C0 strict {} 0 {} {} + iso8859-8 C1 tcl8 \U000000C1 -1 {} {} + iso8859-8 C1 replace \uFFFD -1 {} {} + iso8859-8 C1 strict {} 0 {} {} + iso8859-8 C2 tcl8 \U000000C2 -1 {} {} + iso8859-8 C2 replace \uFFFD -1 {} {} + iso8859-8 C2 strict {} 0 {} {} + iso8859-8 C3 tcl8 \U000000C3 -1 {} {} + iso8859-8 C3 replace \uFFFD -1 {} {} + iso8859-8 C3 strict {} 0 {} {} + iso8859-8 C4 tcl8 \U000000C4 -1 {} {} + iso8859-8 C4 replace \uFFFD -1 {} {} + iso8859-8 C4 strict {} 0 {} {} + iso8859-8 C5 tcl8 \U000000C5 -1 {} {} + iso8859-8 C5 replace \uFFFD -1 {} {} + iso8859-8 C5 strict {} 0 {} {} + iso8859-8 C6 tcl8 \U000000C6 -1 {} {} + iso8859-8 C6 replace \uFFFD -1 {} {} + iso8859-8 C6 strict {} 0 {} {} + iso8859-8 C7 tcl8 \U000000C7 -1 {} {} + iso8859-8 C7 replace \uFFFD -1 {} {} + iso8859-8 C7 strict {} 0 {} {} + iso8859-8 C8 tcl8 \U000000C8 -1 {} {} + iso8859-8 C8 replace \uFFFD -1 {} {} + iso8859-8 C8 strict {} 0 {} {} + iso8859-8 C9 tcl8 \U000000C9 -1 {} {} + iso8859-8 C9 replace \uFFFD -1 {} {} + iso8859-8 C9 strict {} 0 {} {} + iso8859-8 CA tcl8 \U000000CA -1 {} {} + iso8859-8 CA replace \uFFFD -1 {} {} + iso8859-8 CA strict {} 0 {} {} + iso8859-8 CB tcl8 \U000000CB -1 {} {} + iso8859-8 CB replace \uFFFD -1 {} {} + iso8859-8 CB strict {} 0 {} {} + iso8859-8 CC tcl8 \U000000CC -1 {} {} + iso8859-8 CC replace \uFFFD -1 {} {} + iso8859-8 CC strict {} 0 {} {} + iso8859-8 CD tcl8 \U000000CD -1 {} {} + iso8859-8 CD replace \uFFFD -1 {} {} + iso8859-8 CD strict {} 0 {} {} + iso8859-8 CE tcl8 \U000000CE -1 {} {} + iso8859-8 CE replace \uFFFD -1 {} {} + iso8859-8 CE strict {} 0 {} {} + iso8859-8 CF tcl8 \U000000CF -1 {} {} + iso8859-8 CF replace \uFFFD -1 {} {} + iso8859-8 CF strict {} 0 {} {} + iso8859-8 D0 tcl8 \U000000D0 -1 {} {} + iso8859-8 D0 replace \uFFFD -1 {} {} + iso8859-8 D0 strict {} 0 {} {} + iso8859-8 D1 tcl8 \U000000D1 -1 {} {} + iso8859-8 D1 replace \uFFFD -1 {} {} + iso8859-8 D1 strict {} 0 {} {} + iso8859-8 D2 tcl8 \U000000D2 -1 {} {} + iso8859-8 D2 replace \uFFFD -1 {} {} + iso8859-8 D2 strict {} 0 {} {} + iso8859-8 D3 tcl8 \U000000D3 -1 {} {} + iso8859-8 D3 replace \uFFFD -1 {} {} + iso8859-8 D3 strict {} 0 {} {} + iso8859-8 D4 tcl8 \U000000D4 -1 {} {} + iso8859-8 D4 replace \uFFFD -1 {} {} + iso8859-8 D4 strict {} 0 {} {} + iso8859-8 D5 tcl8 \U000000D5 -1 {} {} + iso8859-8 D5 replace \uFFFD -1 {} {} + iso8859-8 D5 strict {} 0 {} {} + iso8859-8 D6 tcl8 \U000000D6 -1 {} {} + iso8859-8 D6 replace \uFFFD -1 {} {} + iso8859-8 D6 strict {} 0 {} {} + iso8859-8 D7 tcl8 \U000000D7 -1 {} {} + iso8859-8 D7 replace \uFFFD -1 {} {} + iso8859-8 D7 strict {} 0 {} {} + iso8859-8 D8 tcl8 \U000000D8 -1 {} {} + iso8859-8 D8 replace \uFFFD -1 {} {} + iso8859-8 D8 strict {} 0 {} {} + iso8859-8 D9 tcl8 \U000000D9 -1 {} {} + iso8859-8 D9 replace \uFFFD -1 {} {} + iso8859-8 D9 strict {} 0 {} {} + iso8859-8 DA tcl8 \U000000DA -1 {} {} + iso8859-8 DA replace \uFFFD -1 {} {} + iso8859-8 DA strict {} 0 {} {} + iso8859-8 DB tcl8 \U000000DB -1 {} {} + iso8859-8 DB replace \uFFFD -1 {} {} + iso8859-8 DB strict {} 0 {} {} + iso8859-8 DC tcl8 \U000000DC -1 {} {} + iso8859-8 DC replace \uFFFD -1 {} {} + iso8859-8 DC strict {} 0 {} {} + iso8859-8 DD tcl8 \U000000DD -1 {} {} + iso8859-8 DD replace \uFFFD -1 {} {} + iso8859-8 DD strict {} 0 {} {} + iso8859-8 DE tcl8 \U000000DE -1 {} {} + iso8859-8 DE replace \uFFFD -1 {} {} + iso8859-8 DE strict {} 0 {} {} + iso8859-8 FB tcl8 \U000000FB -1 {} {} + iso8859-8 FB replace \uFFFD -1 {} {} + iso8859-8 FB strict {} 0 {} {} + iso8859-8 FC tcl8 \U000000FC -1 {} {} + iso8859-8 FC replace \uFFFD -1 {} {} + iso8859-8 FC strict {} 0 {} {} + iso8859-8 FF tcl8 \U000000FF -1 {} {} + iso8859-8 FF replace \uFFFD -1 {} {} + iso8859-8 FF strict {} 0 {} {} +}; # iso8859-8 + +# iso8859-8 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-8 \U000000A1 tcl8 1A -1 {} {} + iso8859-8 \U000000A1 replace 1A -1 {} {} + iso8859-8 \U000000A1 strict {} 0 {} {} + iso8859-8 \U00000400 tcl8 1A -1 {} {} + iso8859-8 \U00000400 replace 1A -1 {} {} + iso8859-8 \U00000400 strict {} 0 {} {} + iso8859-8 \U0000D800 tcl8 1A -1 {} {} + iso8859-8 \U0000D800 replace 1A -1 {} {} + iso8859-8 \U0000D800 strict {} 0 {} {} + iso8859-8 \U0000DC00 tcl8 1A -1 {} {} + iso8859-8 \U0000DC00 replace 1A -1 {} {} + iso8859-8 \U0000DC00 strict {} 0 {} {} + iso8859-8 \U00010000 tcl8 1A -1 {} {} + iso8859-8 \U00010000 replace 1A -1 {} {} + iso8859-8 \U00010000 strict {} 0 {} {} + iso8859-8 \U0010FFFF tcl8 1A -1 {} {} + iso8859-8 \U0010FFFF replace 1A -1 {} {} + iso8859-8 \U0010FFFF strict {} 0 {} {} +}; # iso8859-8 + +# +# iso8859-9 (generated from glibc-ISO_8859_9-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-9 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-9 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE} +} -result {} + +# iso8859-9 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-9 + +# iso8859-9 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-9 \U000000D0 tcl8 1A -1 {} {} + iso8859-9 \U000000D0 replace 1A -1 {} {} + iso8859-9 \U000000D0 strict {} 0 {} {} + iso8859-9 \U00000400 tcl8 1A -1 {} {} + iso8859-9 \U00000400 replace 1A -1 {} {} + iso8859-9 \U00000400 strict {} 0 {} {} + iso8859-9 \U0000D800 tcl8 1A -1 {} {} + iso8859-9 \U0000D800 replace 1A -1 {} {} + iso8859-9 \U0000D800 strict {} 0 {} {} + iso8859-9 \U0000DC00 tcl8 1A -1 {} {} + iso8859-9 \U0000DC00 replace 1A -1 {} {} + iso8859-9 \U0000DC00 strict {} 0 {} {} + iso8859-9 \U00010000 tcl8 1A -1 {} {} + iso8859-9 \U00010000 replace 1A -1 {} {} + iso8859-9 \U00010000 strict {} 0 {} {} + iso8859-9 \U0010FFFF tcl8 1A -1 {} {} + iso8859-9 \U0010FFFF replace 1A -1 {} {} + iso8859-9 \U0010FFFF strict {} 0 {} {} +}; # iso8859-9 + +# +# iso8859-10 (generated from glibc-ISO_8859_10-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-10 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-10 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD} +} -result {} + +# iso8859-10 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-10 + +# iso8859-10 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-10 \U000000A1 tcl8 1A -1 {} {} + iso8859-10 \U000000A1 replace 1A -1 {} {} + iso8859-10 \U000000A1 strict {} 0 {} {} + iso8859-10 \U00000400 tcl8 1A -1 {} {} + iso8859-10 \U00000400 replace 1A -1 {} {} + iso8859-10 \U00000400 strict {} 0 {} {} + iso8859-10 \U0000D800 tcl8 1A -1 {} {} + iso8859-10 \U0000D800 replace 1A -1 {} {} + iso8859-10 \U0000D800 strict {} 0 {} {} + iso8859-10 \U0000DC00 tcl8 1A -1 {} {} + iso8859-10 \U0000DC00 replace 1A -1 {} {} + iso8859-10 \U0000DC00 strict {} 0 {} {} + iso8859-10 \U00010000 tcl8 1A -1 {} {} + iso8859-10 \U00010000 replace 1A -1 {} {} + iso8859-10 \U00010000 strict {} 0 {} {} + iso8859-10 \U0010FFFF tcl8 1A -1 {} {} + iso8859-10 \U0010FFFF replace 1A -1 {} {} + iso8859-10 \U0010FFFF strict {} 0 {} {} +}; # iso8859-10 + +# +# iso8859-11 (generated from glibc-ISO_8859_11-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-11 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-11 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB} +} -result {} + +# iso8859-11 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-11 DB tcl8 \U000000DB -1 {} {} + iso8859-11 DB replace \uFFFD -1 {} {} + iso8859-11 DB strict {} 0 {} {} + iso8859-11 DC tcl8 \U000000DC -1 {} {} + iso8859-11 DC replace \uFFFD -1 {} {} + iso8859-11 DC strict {} 0 {} {} + iso8859-11 DD tcl8 \U000000DD -1 {} {} + iso8859-11 DD replace \uFFFD -1 {} {} + iso8859-11 DD strict {} 0 {} {} + iso8859-11 DE tcl8 \U000000DE -1 {} {} + iso8859-11 DE replace \uFFFD -1 {} {} + iso8859-11 DE strict {} 0 {} {} + iso8859-11 FC tcl8 \U000000FC -1 {} {} + iso8859-11 FC replace \uFFFD -1 {} {} + iso8859-11 FC strict {} 0 {} {} + iso8859-11 FD tcl8 \U000000FD -1 {} {} + iso8859-11 FD replace \uFFFD -1 {} {} + iso8859-11 FD strict {} 0 {} {} + iso8859-11 FE tcl8 \U000000FE -1 {} {} + iso8859-11 FE replace \uFFFD -1 {} {} + iso8859-11 FE strict {} 0 {} {} + iso8859-11 FF tcl8 \U000000FF -1 {} {} + iso8859-11 FF replace \uFFFD -1 {} {} + iso8859-11 FF strict {} 0 {} {} +}; # iso8859-11 + +# iso8859-11 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-11 \U000000A1 tcl8 1A -1 {} {} + iso8859-11 \U000000A1 replace 1A -1 {} {} + iso8859-11 \U000000A1 strict {} 0 {} {} + iso8859-11 \U00000400 tcl8 1A -1 {} {} + iso8859-11 \U00000400 replace 1A -1 {} {} + iso8859-11 \U00000400 strict {} 0 {} {} + iso8859-11 \U0000D800 tcl8 1A -1 {} {} + iso8859-11 \U0000D800 replace 1A -1 {} {} + iso8859-11 \U0000D800 strict {} 0 {} {} + iso8859-11 \U0000DC00 tcl8 1A -1 {} {} + iso8859-11 \U0000DC00 replace 1A -1 {} {} + iso8859-11 \U0000DC00 strict {} 0 {} {} + iso8859-11 \U00010000 tcl8 1A -1 {} {} + iso8859-11 \U00010000 replace 1A -1 {} {} + iso8859-11 \U00010000 strict {} 0 {} {} + iso8859-11 \U0010FFFF tcl8 1A -1 {} {} + iso8859-11 \U0010FFFF replace 1A -1 {} {} + iso8859-11 \U0010FFFF strict {} 0 {} {} +}; # iso8859-11 + +# +# iso8859-13 (generated from glibc-ISO_8859_13-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-13 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-13 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5} +} -result {} + +# iso8859-13 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-13 + +# iso8859-13 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-13 \U000000A1 tcl8 1A -1 {} {} + iso8859-13 \U000000A1 replace 1A -1 {} {} + iso8859-13 \U000000A1 strict {} 0 {} {} + iso8859-13 \U00000400 tcl8 1A -1 {} {} + iso8859-13 \U00000400 replace 1A -1 {} {} + iso8859-13 \U00000400 strict {} 0 {} {} + iso8859-13 \U0000D800 tcl8 1A -1 {} {} + iso8859-13 \U0000D800 replace 1A -1 {} {} + iso8859-13 \U0000D800 strict {} 0 {} {} + iso8859-13 \U0000DC00 tcl8 1A -1 {} {} + iso8859-13 \U0000DC00 replace 1A -1 {} {} + iso8859-13 \U0000DC00 strict {} 0 {} {} + iso8859-13 \U00010000 tcl8 1A -1 {} {} + iso8859-13 \U00010000 replace 1A -1 {} {} + iso8859-13 \U00010000 strict {} 0 {} {} + iso8859-13 \U0010FFFF tcl8 1A -1 {} {} + iso8859-13 \U0010FFFF replace 1A -1 {} {} + iso8859-13 \U0010FFFF strict {} 0 {} {} +}; # iso8859-13 + +# +# iso8859-14 (generated from glibc-ISO_8859_14-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-14 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-14 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC} +} -result {} + +# iso8859-14 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-14 + +# iso8859-14 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-14 \U000000A1 tcl8 1A -1 {} {} + iso8859-14 \U000000A1 replace 1A -1 {} {} + iso8859-14 \U000000A1 strict {} 0 {} {} + iso8859-14 \U00000400 tcl8 1A -1 {} {} + iso8859-14 \U00000400 replace 1A -1 {} {} + iso8859-14 \U00000400 strict {} 0 {} {} + iso8859-14 \U0000D800 tcl8 1A -1 {} {} + iso8859-14 \U0000D800 replace 1A -1 {} {} + iso8859-14 \U0000D800 strict {} 0 {} {} + iso8859-14 \U0000DC00 tcl8 1A -1 {} {} + iso8859-14 \U0000DC00 replace 1A -1 {} {} + iso8859-14 \U0000DC00 strict {} 0 {} {} + iso8859-14 \U00010000 tcl8 1A -1 {} {} + iso8859-14 \U00010000 replace 1A -1 {} {} + iso8859-14 \U00010000 strict {} 0 {} {} + iso8859-14 \U0010FFFF tcl8 1A -1 {} {} + iso8859-14 \U0010FFFF replace 1A -1 {} {} + iso8859-14 \U0010FFFF strict {} 0 {} {} +}; # iso8859-14 + +# +# iso8859-15 (generated from glibc-ISO_8859_15-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-15 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-15 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4} +} -result {} + +# iso8859-15 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-15 + +# iso8859-15 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-15 \U000000A4 tcl8 1A -1 {} {} + iso8859-15 \U000000A4 replace 1A -1 {} {} + iso8859-15 \U000000A4 strict {} 0 {} {} + iso8859-15 \U00000400 tcl8 1A -1 {} {} + iso8859-15 \U00000400 replace 1A -1 {} {} + iso8859-15 \U00000400 strict {} 0 {} {} + iso8859-15 \U0000D800 tcl8 1A -1 {} {} + iso8859-15 \U0000D800 replace 1A -1 {} {} + iso8859-15 \U0000D800 strict {} 0 {} {} + iso8859-15 \U0000DC00 tcl8 1A -1 {} {} + iso8859-15 \U0000DC00 replace 1A -1 {} {} + iso8859-15 \U0000DC00 strict {} 0 {} {} + iso8859-15 \U00010000 tcl8 1A -1 {} {} + iso8859-15 \U00010000 replace 1A -1 {} {} + iso8859-15 \U00010000 strict {} 0 {} {} + iso8859-15 \U0010FFFF tcl8 1A -1 {} {} + iso8859-15 \U0010FFFF replace 1A -1 {} {} + iso8859-15 \U0010FFFF strict {} 0 {} {} +}; # iso8859-15 + +# +# iso8859-16 (generated from glibc-ISO_8859_16-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-16 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-16 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4} +} -result {} + +# iso8859-16 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-16 + +# iso8859-16 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-16 \U000000A1 tcl8 1A -1 {} {} + iso8859-16 \U000000A1 replace 1A -1 {} {} + iso8859-16 \U000000A1 strict {} 0 {} {} + iso8859-16 \U00000400 tcl8 1A -1 {} {} + iso8859-16 \U00000400 replace 1A -1 {} {} + iso8859-16 \U00000400 strict {} 0 {} {} + iso8859-16 \U0000D800 tcl8 1A -1 {} {} + iso8859-16 \U0000D800 replace 1A -1 {} {} + iso8859-16 \U0000D800 strict {} 0 {} {} + iso8859-16 \U0000DC00 tcl8 1A -1 {} {} + iso8859-16 \U0000DC00 replace 1A -1 {} {} + iso8859-16 \U0000DC00 strict {} 0 {} {} + iso8859-16 \U00010000 tcl8 1A -1 {} {} + iso8859-16 \U00010000 replace 1A -1 {} {} + iso8859-16 \U00010000 strict {} 0 {} {} + iso8859-16 \U0010FFFF tcl8 1A -1 {} {} + iso8859-16 \U0010FFFF replace 1A -1 {} {} + iso8859-16 \U0010FFFF strict {} 0 {} {} +}; # iso8859-16 diff --git a/tests/if-old.test b/tests/if-old.test index e537fea..378c8a6 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -6,9 +6,9 @@ # 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. diff --git a/tests/if.test b/tests/if.test index e589351..a1399a0 100644 --- a/tests/if.test +++ b/tests/if.test @@ -4,8 +4,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) 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. @@ -1265,7 +1265,7 @@ test if-10.6 {double invocation of variable traces} -body { set var "$counter + [concat $extraargs]" } } - trace variable iftracevar r [list iftraceproc 10] + trace add variable iftracevar read [list iftraceproc 10] list [catch {if "$iftracevar + 20" {}} a] $a \ [catch {if "$iftracevar + 20" {}} b] $b } -cleanup { diff --git a/tests/incr-old.test b/tests/incr-old.test index 5d792e1..662fdc7 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -6,9 +6,9 @@ # 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. @@ -63,7 +63,7 @@ test incr-old-2.5 {incr errors} { test incr-old-2.6 {incr errors} -body { proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + trace add var x write readonly list [catch {incr x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing diff --git a/tests/incr.test b/tests/incr.test index af15f5e..04c3652 100644 --- a/tests/incr.test +++ b/tests/incr.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) 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. @@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} { (reading increment) invoked from within "incr x 1a"}} +test incr-2.32 {incr command (compiled): bad pure list increment} { + list [catch {incr x [list 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [list 1 2]"}} +test incr-2.33 {incr command (compiled): bad pure dict increment} { + list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 diff --git a/tests/indexObj.test b/tests/indexObj.test index 6be0eb4..1cf782a 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -2,8 +2,8 @@ # 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 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. @@ -14,9 +14,10 @@ if {"::tcltest" ni [namespace children]} { } ::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 testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] test indexObj-1.1 {exact match} testindexobj { @@ -109,7 +110,7 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { } {wrong # args: should be "mycmd foo"} # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. -test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { +test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} { testwrongnumargs 2 "fee fi" "fo fum" foo bar } {wrong # args: should be "fo fum foo fee fi"} @@ -139,6 +140,10 @@ test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testi set x "" testgetindexfromobjstruct $x 0 } -returnCodes error -result {ambiguous dummy "": must be a, c, or ee} +test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj { + set x "" + testgetindexfromobjstruct $x -1 32 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs @@ -165,6 +170,58 @@ test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 } {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} +test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex 0 0 +} 0 +test indexObj-8.2 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -1 0 +} -1 +test indexObj-8.3 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -2 0 +} -1 +test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex { + testgetintforindex 2147483647 0 +} 2147483647 +test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex { + testgetintforindex 2147483648 0 +} 2147483647 +test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483646 +} 2147483645 +test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483647 +} 2147483646 +test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483646 +} 2147483646 +test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483647 +} 2147483647 +test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -1 +} -2 +test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -2 +} -3 +test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -1 +} -1 +test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -2 +} -2 +test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -1 +} 2147483647 +test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -2 +} -1 +test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -1 -1 +} -2147483648 +test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -2 -1 +} -2147483648 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/info.test b/tests/info.test index 69be6a3..ef41bdf 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. @@ -19,10 +19,10 @@ if {{::tcltest} ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } - ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - +source [file join [file dirname [info script]] tcltests.tcl] +catch [list package require -exact tcl::test [info patchlevel]] +testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -33,7 +33,7 @@ namespace eval test_ns_info1 { proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } - + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} { +test info-2.6 {info body option, returning list bodies} deprecated { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] @@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} { proc testinfocmdcount {} { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } test info-3.1 {info cmdcount compiled} { @@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} { test info-3.2 {info cmdcount evaled} -body { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } -cleanup {unset x y z} -result 4 test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 @@ -397,8 +397,8 @@ test info-10.3 {info library option} -body { set tcl_library $savedLibrary; unset savedLibrary test info-11.1 {info loaded option} -body { - info loaded a b -} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} + info loaded a b c +} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} test info-11.2 {info loaded option} -body { info loaded {}; info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} @@ -655,7 +655,7 @@ test info-19.6 {info vars: Bug 1072654} -setup { namespace delete x } -result {} -set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} +set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} # Check whether the extra testing functions are defined... if {!([catch {expr {T1()}} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### @@ -1841,7 +1841,7 @@ test info-30.48 {Bug 2850901} testevalex { # ------------------------------------------------------------------------- # literal sharing 2, bug 2933089 -test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup { +test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { set result {} proc print_one {} {} @@ -2396,6 +2396,174 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval ::testinfocmdtype { + apply {cmds { + foreach c $cmds {rename $c {}} + } ::testinfocmdtype} [info commands ::testinfocmdtype::*] +} +test info-40.1 {info cmdtype: syntax} -body { + info cmdtype +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.2 {info cmdtype: syntax} -body { + info cmdtype foo bar +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.3 {info cmdtype: no such command} -body { + info cmdtype ::testinfocmdtype::foo +} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} +test info-40.4 {info cmdtype: native commands} -body { + info cmdtype ::if +} -result native +test info-40.5 {info cmdtype: native commands} -body { + info cmdtype ::puts +} -result native +test info-40.6 {info cmdtype: native commands} -body { + info cmdtype ::yield +} -result native +test info-40.7 {info cmdtype: procedures} -setup { + proc ::testinfocmdtype::someproc {} {} +} -body { + info cmdtype ::testinfocmdtype::someproc +} -cleanup { + rename ::testinfocmdtype::someproc {} +} -result proc +test info-40.8 {info cmdtype: aliases} -setup { + interp alias {} ::testinfocmdtype::somealias {} ::puts +} -body { + info cmdtype ::testinfocmdtype::somealias +} -cleanup { + rename ::testinfocmdtype::somealias {} +} -result alias +test info-40.9 {info cmdtype: imports} -setup { + namespace eval ::testinfocmdtype { + namespace eval foo { + proc bar {} {} + namespace export bar + } + namespace import foo::bar + } +} -body { + info cmdtype ::testinfocmdtype::bar +} -cleanup { + rename ::testinfocmdtype::bar {} + namespace delete ::testinfocmdtype::foo +} -result import +test info-40.10 {info cmdtype: interps} -setup { + apply {i { + rename $i ::testinfocmdtype::child + variable ::testinfocmdtype::child $i + }} [interp create] +} -body { + info cmdtype ::testinfocmdtype::child +} -cleanup { + interp delete $::testinfocmdtype::child +} -result interp +test info-40.11 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype ::testinfocmdtype::obj +} -cleanup { + ::testinfocmdtype::obj destroy +} -result object +test info-40.12 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype [info object namespace ::testinfocmdtype::obj]::my +} -cleanup { + ::testinfocmdtype::obj destroy +} -result privateObject +test info-40.13 {info cmdtype: ensembles} -setup { + namespace eval ::testinfocmdtype { + namespace eval ensmbl { + proc bar {} {} + namespace export * + namespace ensemble create + } + } +} -body { + info cmdtype ::testinfocmdtype::ensmbl +} -cleanup { + namespace delete ::testinfocmdtype::ensmbl +} -result ensemble +test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { + namespace eval ::testinfocmdtype { + rename [zlib stream gzip] zstream + } +} -body { + info cmdtype ::testinfocmdtype::zstream +} -cleanup { + ::testinfocmdtype::zstream close +} -result zlibStream +test info-40.15 {info cmdtype: coroutines} -setup { + coroutine ::testinfocmdtype::coro eval yield +} -body { + info cmdtype ::testinfocmdtype::coro +} -cleanup { + ::testinfocmdtype::coro +} -result coroutine +test info-40.16 {info cmdtype: dynamic behavior} -setup { + proc ::testinfocmdtype::foo {} {} +} -body { + namespace eval ::testinfocmdtype { + list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ + [namespace which foo] [rename foo bar] [namespace which bar] \ + [catch {info cmdtype foo}] [catch {info cmdtype bar}] + } +} -cleanup { + namespace eval ::testinfocmdtype { + catch {rename foo {}} + catch {rename bar {}} + } +} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} +test info-40.17 {info cmdtype: aliases in child interpreters} -setup { + set i [interp create] +} -body { + $i alias foo gorp + $i eval { + info cmdtype foo + } +} -cleanup { + interp delete $i +} -result alias +test info-40.18 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe alias foo gorp + $safe eval { + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.19 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + set inner [interp create [list $safe bar]] + interp alias $inner foo $safe gorp + $safe eval { + bar eval { + info cmdtype foo + } + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.20 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe eval { + interp alias {} foo {} gorp + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +namespace delete ::testinfocmdtype + +# ------------------------------------------------------------------------- unset -nocomplain res test info-39.2 {Bug 4b61afd660} -setup { diff --git a/tests/init.test b/tests/init.test index 91df4a1..ac80016 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::* } @@ -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 { @@ -170,7 +170,7 @@ foreach arg [subst -nocommands -novariables { auto_reset } -body { namespace eval junk [list array set $arg [list 1 2 3 4]] - trace variable ::junk::$arg r \ + trace add variable ::junk::$arg read \ "[list error [subst {Variable \"$arg\" is write-only}]] ;# " catch {parray ::junk::$arg} set first $::errorInfo diff --git a/tests/internals.tcl b/tests/internals.tcl index 43cafd5..36dbc90 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. @@ -93,4 +93,4 @@ namespace export test* # for script path & as mark for loaded proc scriptpath {} [list return [info script]] -}}; # end of internals. +}}; # end of internals.
\ No newline at end of file diff --git a/tests/interp.test b/tests/interp.test index d742484..fa263e2 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -4,23 +4,23 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 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:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} foreach i [interp 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, children, 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 } "" @@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body { } -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, children, 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, children, 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, children, 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"} @@ -1640,7 +1640,7 @@ test interp-20.50.1 {Bug 2486550} -setup { } -cleanup { unset -nocomplain m 0 interp delete child -} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" +} -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within @@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup { lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} @@ -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 diff --git a/tests/io.test b/tests/io.test index 50a6018..6d985ee 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6,19 +6,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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. -namespace eval ::tcl::test::io { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 +} - if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* - } +namespace eval ::tcl::test::io { + namespace import ::tcltest::* variable umaskValue variable path @@ -31,8 +31,8 @@ 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] } source [file join [file dirname [info script]] tcltests.tcl] @@ -79,7 +79,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 \x1A" fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -110,14 +110,14 @@ 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\x00" + puts -nonewline $f "a\x4D\x00" close $f contents $path(test1) } "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\x00" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) } "a\x93\xE1\x00" @@ -274,7 +274,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 -profile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -288,7 +288,7 @@ test io-3.5 {WriteChars: saved != 0} -body { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 -profile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -301,14 +301,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)] @@ -321,7 +321,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 -profile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -468,7 +468,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\x00" + puts $f "\x81\x34\x00" close $f set f [open $path(test1)] fconfigure $f -translation binary @@ -486,7 +486,7 @@ test io-6.5 {Tcl_GetsObj: encoding != NULL} { 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 @@ -519,17 +519,17 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1A + fconfigure $f -eofchar "\x1A \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 \x1A" set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -940,7 +940,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" fconfigure $f -buffersize 16 gets $f @@ -1038,7 +1038,7 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1A + fconfigure $f -eofchar "\x1A \x1A" set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1069,14 +1069,14 @@ 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"] +} [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+] @@ -1103,14 +1103,14 @@ 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) @@ -1119,7 +1119,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + fconfigure $f -encoding shiftjis -profile tcl8 set x [list [gets $f line] $line [eof $f]] close $f set x @@ -1130,13 +1130,13 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + fconfigure $f -encoding shiftjis -profile tcl8 set x [list [gets $f line] $line] lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] lappend x [gets $f line] $line close $f set x -} [list 16 "1234567890123\uFF10\uFF11\x82" 18 0 1 -1 ""] +} [list 16 "1234567890123０１\x82" 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 @@ -1155,7 +1155,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent 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) @@ -1184,7 +1184,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] fconfigure $f -translation auto -encoding ascii -blocking 1 # here @@ -1438,7 +1438,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { vwait [namespace which -variable x] close $f set x -} [list "123456789012345" 1 "\u672C" 0] +} [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 @@ -1471,70 +1471,70 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { 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 - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 20][string repeat . 20]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 15 + read $c 15 } close $c } {} test io-12.7 {ReadChars: too many chars read [bc5b790099]} { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 10]....\uBEEF] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 10]....뻯] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 7 + read $c 7 } close $c } {} @@ -1555,20 +1555,34 @@ test io-12.9 {ReadChars: multibyte chars split} -body { puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] - fconfigure $f -encoding utf-8 -buffersize 10 + fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10 set in [read $f] - close $f + read $f scan [string index $in end] %c } -cleanup { catch {close $f} } -result 194 -test io-12.10 {ReadChars: multibyte chars split} -body { +test io-12.11 {ReadChars: multibyte chars split} -body { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xC2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -profile strict -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} -cleanup { + catch {close $f} +} -returnCodes 1 -match glob -result {error reading "file*":\ + invalid or incomplete multibyte or wide character} +test io-12.12 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] - fconfigure $f -encoding utf-8 -buffersize 11 + fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 11 set in [read $f] close $f scan [string index $in end] %c @@ -1925,7 +1939,7 @@ test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(test1) set f [open $path(script) w] puts $f { - array set path [lindex $argv 0] + array set path [lindex $argv 0] set f [open $path(test1) w] puts $f hello close $f @@ -2272,7 +2286,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -2286,9 +2300,9 @@ test io-27.6 {FlushChannel, async flushing, async close} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result "file size only [file size $path(output)]" + set result "file size only [file size $path(output)]" } else { - set result ok + set result ok } } ok @@ -2347,7 +2361,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -2362,9 +2376,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result probably_broken + set result probably_broken } else { - set result ok + set result ok } } ok test io-28.4 Tcl_Close testchannel { @@ -2394,6 +2408,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { lsort $l } {file1 file2} + +test io-28.6 { + close channel in write event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create w {apply {args { + list initialize finalize watch write configure blocking + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan writable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + +test io-28.7 { + close channel in read event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create r {apply {{cmd chan args} { + switch $cmd { + blocking - finalize { + } + watch { + chan postevent $chan read + } + initialize { + list initialize finalize watch read write configure blocking + } + default { + error [list {unexpected command} $cmd] + } + } + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan readable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + + test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} @@ -3316,7 +3398,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [read $f] close $f set c @@ -3328,11 +3410,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 -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [read $f] close $f set c @@ -3349,7 +3431,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3369,7 +3451,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3447,7 +3529,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3461,7 +3543,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3475,7 +3557,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3489,7 +3571,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3503,7 +3585,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3517,7 +3599,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 \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3850,7 +3932,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3865,11 +3947,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 -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3889,7 +3971,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3907,7 +3989,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3991,7 +4073,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4009,7 +4091,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4027,7 +4109,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4045,7 +4127,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4063,7 +4145,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4081,7 +4163,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 \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4484,29 +4566,29 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { } 300 test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4518,29 +4600,29 @@ test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4552,30 +4634,30 @@ test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [string repeat \ - [string repeat . 64]\n[string repeat . 25] 2] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - if {$n > 65} {set n 65} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4962,12 +5044,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { 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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -4976,12 +5058,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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -4990,12 +5072,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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5004,12 +5086,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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5018,12 +5100,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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5032,12 +5114,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 \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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5052,7 +5134,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5067,7 +5149,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5082,7 +5164,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5097,7 +5179,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5112,7 +5194,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5127,7 +5209,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 \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5150,12 +5232,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 \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 \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5164,12 +5246,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 \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 \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5198,7 +5280,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 \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5213,7 +5295,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 \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5296,8 +5378,8 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} { } {0 abc 0 defghijklmnop 0 1} test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5332,8 +5414,8 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles } {0 abc 0 defghijklmnop 0 1} test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5408,7 +5490,7 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - fconfigure $chan -buffersize 10 + fconfigure $chan -buffersize 10 -encoding utf-8 set var [read $chan 2] fconfigure $chan -buffersize 32 append var [read $chan] @@ -5596,7 +5678,7 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & 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] @@ -5608,7 +5690,7 @@ test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.16 {Tcl_SetChannelOption: -encoding (shortened to "-en"), errors} -body { file delete $path(test1) set f [open $path(test1) w] @@ -5697,32 +5779,32 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { +test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix} -body { file delete $path(test1) set f1 [open $path(test1) w+] set l "" lappend l [fconfigure $f1 -eofchar] fconfigure $f1 -eofchar {ON GO} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D + fconfigure $f1 -eofchar {D D} lappend l [fconfigure $f1 -eofchar] close $f1 set l -} {{{} {}} {O G} {D D}} -test io-39.22a {Tcl_SetChannelOption, invariance} { +} -result {{{} {}} {O G} {D D}} +test io-39.22a {Tcl_SetChannelOption, invariance} -body { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] fconfigure $f1 -eofchar {ON GO} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D + fconfigure $f1 -eofchar {D D} lappend l [fconfigure $f1 -eofchar] lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or - writable, it should still have valid -eofchar and -translation options } { + writable, it should still have valid -eofchar and -translation options } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] @@ -5730,7 +5812,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or set l } {{{}} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or - writable so we can't change -eofchar or -translation } { + writable so we can't change -eofchar or -translation } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] fconfigure $sock -eofchar D -translation lf @@ -5758,7 +5840,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix notWsl} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "0o%o" [expr {$stats(mode)&0o777}]] + set x [format "%#o" [expr {$stats(mode)&0o777}]] puts $f "line 1" close $f set f [open $path(test3) r] @@ -6088,6 +6170,70 @@ test io-44.5 {FileEventProc procedure: end of file} -constraints { } -result {initial foo eof} close $f + +test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { +} -constraints {stdio fileevent openpipe} -body { + + namespace eval refchan { + namespace ensemble create + namespace export * + + + proc finalize {chan args} { + namespace delete c_$chan + } + + proc initialize {chan args} { + namespace eval c_$chan {} + namespace upvar c_$chan watching watching + set watching {} + list finalize initialize seek watch write + } + + + proc watch {chan args} { + namespace upvar c_$chan watching watching + foreach arg $args { + switch $arg { + write { + if {$arg ni $watching} { + lappend watching $arg + } + chan postevent $chan $arg + } + } + } + } + + + proc write {chan args} { + chan postevent $chan write + return 1 + } + } + set f [chan create w [namespace which refchan]] + chan configure $f -blocking 0 + set data "some data" + set x 0 + chan event $f writable [namespace code { + puts $f $data + incr count [string length $data] + if {$count > 262144} { + chan event $f writable {} + set x done + } + }] + set token [after 10000 [namespace code { + set x timeout + }]] + vwait [namespace which -variable x] + return $x +} -cleanup { + after cancel $token + catch {chan close $f} +} -result done + + makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { @@ -6164,23 +6310,23 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent not test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - variable x 0 - after 100 {set x triggered} - vwait [namespace which -variable x] - set x + variable x 0 + after 100 {set x triggered} + vwait [namespace which -variable x] + set x } } {triggered} test io-46.3 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - set x 0 - after 10 {lappend x timer} - after 30 - set result $x - update idletasks - lappend result $x - update - lappend result $x + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x } } {0 0 {0 timer}} @@ -6197,7 +6343,7 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} { lappend x [fileevent $f2 readable] testfevent delete lappend x [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] + [fileevent $f3 readable] close $f close $f2 close $f3 @@ -6213,11 +6359,11 @@ test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} { testfevent share $f2 testfevent share $f3 testfevent cmd "fileevent $f2 readable {script 2} - fileevent $f3 readable {script 3}" + fileevent $f3 readable {script 3}" fileevent $f4 readable {script 4} testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6235,10 +6381,10 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { fileevent $f readable {script 1} fileevent $f2 readable {script 2} testfevent cmd "fileevent $f3 readable {script 3} - fileevent $f4 readable {script 4}" + fileevent $f4 readable {script 4}" testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6254,8 +6400,8 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent $f readable {script 2} fileevent $f2 readable {script 3} set x [list [fileevent $f2 readable] \ - [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] testfevent delete close $f close $f2 @@ -6269,7 +6415,7 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} testfevent cmd "fileevent $f readable {}" set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -6282,7 +6428,7 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} fileevent $f readable {} set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -6416,7 +6562,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6444,7 +6590,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6472,7 +6618,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6500,7 +6646,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6528,7 +6674,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6556,7 +6702,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 -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6584,7 +6730,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 -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6612,7 +6758,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6640,7 +6786,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 -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6668,7 +6814,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6696,7 +6842,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 -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6724,7 +6870,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 \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -7116,8 +7262,8 @@ test io-52.3 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation cr -encoding iso8859-1 -blocking 0 set s0 [fcopy $f1 $f2] set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7125,7 +7271,7 @@ test io-52.3 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7157,8 +7303,8 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7166,7 +7312,7 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7174,8 +7320,8 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7183,7 +7329,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7191,8 +7337,8 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7200,7 +7346,7 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7208,8 +7354,8 @@ test io-52.6 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 set s0 [fcopy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7217,7 +7363,7 @@ test io-52.6 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7225,8 +7371,8 @@ test io-52.7 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] set s1 [file size $thisScript] @@ -7234,7 +7380,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { close $f1 close $f2 if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7271,7 +7417,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. @@ -7303,7 +7449,7 @@ test io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test io-52.10 {TclCopyChannel & encodings} {fcopy} { +test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { # encoding to binary (=> implies that the # internal utf-8 is written) @@ -7315,15 +7461,16 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { fconfigure $out -translation binary fcopy $in $out - close $in - close $out file size $path(utf8-fcopy.txt) -} 5 +} -cleanup { + close $in + close $out +} -result 5 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 @@ -7486,6 +7633,103 @@ test io-52.19 {coverage of eofChar handling} { close $out file size $path(test2) } 8 +test io-52.20 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means reading the "Á" gives an error + fconfigure $in -encoding ascii -profile strict + fconfigure $out -encoding koi8-r -translation lf + + fcopy $in $out +} -cleanup { + close $in + close $out +} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} +test io-52.21 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means writing the "Á" gives an error + fconfigure $in -encoding utf-8 + fconfigure $out -encoding ascii -translation lf -profile strict + + fcopy $in $out +} -cleanup { + close $in + close $out +} -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character} +test io-52.22 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means reading the "Á" gives an error + fconfigure $in -encoding ascii -profile strict + fconfigure $out -encoding koi8-r -translation lf + proc ::xxx args { + set ::s0 $args + } + + fcopy $in $out -command ::xxx + vwait ::s0 + set ::s0 +} -cleanup { + close $in + close $out + unset ::s0 +} -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}} +test io-52.23 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means writing the "Á" gives an error + fconfigure $in -encoding utf-8 + fconfigure $out -encoding ascii -translation lf -profile strict + proc ::xxx args { + set ::s0 $args + } + + fcopy $in $out -command ::xxx + vwait ::s0 + set ::s0 +} -cleanup { + close $in + close $out + unset ::s0 +} -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}} + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) @@ -7503,8 +7747,8 @@ test io-53.2 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation cr -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -command [namespace code {set s0}] set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] variable s0 @@ -7514,7 +7758,7 @@ test io-53.2 {CopyData} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7632,6 +7876,8 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]] catch {unset fcopyTestDone} close $listen ;# This means the socket open never really succeeds + fconfigure $in -encoding utf-8 + fconfigure $out -encoding utf-8 fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if {![info exists fcopyTestDone]} { @@ -7669,8 +7915,8 @@ proc doFcopy {in out {bytes 0} {error {}}} { } elseif {[eof $in]} { set fcopyTestDone 0 } else { - # Delay next fcopy to wait for size>0 input bytes - after 100 [list fcopy $in $out -size 1000 \ + # Delay next fcopy to wait for size>0 input bytes + after 100 [list fcopy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } @@ -7685,9 +7931,9 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { proc Write {count} { puts -nonewline "1234567890" if {[incr count -1]} { - after 10 [list Write $count] + after 10 [list Write $count] } else { - set ::ready 1 + set ::ready 1 } } fconfigure stdout -buffering none @@ -7983,7 +8229,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 fcopy} { +test io-53.12.0 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} { file delete $path(pipe) set f1 [open $path(pipe) w] puts -nonewline $f1 { @@ -8002,23 +8248,49 @@ test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fc close $f1 list $::done $ch } {ok A} +test io-53.12.1 { + Issue 9ca87e6286262a62. + CopyData: foreground short reads via ReadChars(). + Related to report 3096275 for ReadBytes(). + + Prior to the fix this test waited forever for read() to return. +} {stdio unix fcopy} { + file delete $path(output) + set f1 [open $path(output) w] + puts -nonewline $f1 { + chan configure stdin -encoding iso8859-1 -translation lf -buffering none + fcopy stdin stdout + } + close $f1 + set f1 [open "|[list [info nameofexecutable] $path(output)]" r+] + try { + chan configure $f1 -encoding utf-8 -buffering none + puts -nonewline $f1 A + set ch [read $f1 1] + } finally { + if {$f1 in [chan names]} { + close $f1 + } + } + lindex $ch +} A test io-53.13 {TclCopyChannel: read error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch read} - } - finalize { - return - } - watch {} - read { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { error FAIL - } - } + } + } } set outFile [makeFile {} out] } -body { @@ -8031,24 +8303,24 @@ test io-53.13 {TclCopyChannel: read error reporting} -setup { catch {close $out} removeFile out rename driver {} -} -result {error reading "*": *} -returnCodes error -match glob +} -result {error reading "rc*": *} -returnCodes error -match glob test io-53.14 {TclCopyChannel: write error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch write} - } - finalize { - return - } - watch {} - write { - error FAIL - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } } set inFile [makeFile {aaa} in] } -body { @@ -8064,35 +8336,35 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup { } -result {error writing "*": *} -returnCodes error -match glob test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 @@ -8108,35 +8380,35 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { } -result 100 test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf @@ -8152,29 +8424,29 @@ test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { } -result 100 test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - line\n[string repeat a 100]line\n] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + line\n[string repeat a 100]line\n] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf -buffersize 107 @@ -8468,7 +8740,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # cut of the remainder of the error stack, especially the filename set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] list $x $result -} {1 {gets ABC catch {error writing "stdout": invalid argument}}} +} {1 {gets ABC catch {error writing "stdout": invalid or incomplete multibyte or wide character}}} test io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] @@ -8802,7 +9074,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] @@ -8810,7 +9082,7 @@ 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] @@ -8830,19 +9102,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} -# The following tests 75.1 to 75.5 exercise strict or tolerant channel -# encoding. -# TCL 8.6 only offers tolerant channel encoding, what is tested here. -test io-75.1 {multibyte encoding error read results in raw bytes} -setup { +test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary # In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed # by a byte > 0x7F. This is violated to get an invalid sequence. - puts -nonewline $f "A\xC0\x40" + puts -nonewline $f A\xC0\x40 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none + fconfigure $f -encoding utf-8 -profile tcl8 -buffering none } -body { set d [read $f] binary scan $d H* hd @@ -8850,54 +9119,54 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup { } -cleanup { close $f removeFile io-75.1 -} -result "41c040" +} -result 41c040 -test io-75.2 {unrepresentable character write passes and is replaced by ?} -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-profile tcl8)} -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 + fconfigure $f -encoding iso8859-1 -profile tcl8 } -body { - puts -nonewline $f "A\u2022" + puts -nonewline $f A\u2022 flush $f seek $f 0 read $f } -cleanup { close $f removeFile io-75.2 -} -result "A?" +} -result A? # Incomplete sequence test. # This error may IMHO only be detected with the close. # But the read already returns the incomplete sequence. -test io-75.3 {incomplete multibyte encoding read is ignored} -setup { +test io-75.3 {incomplete multibyte encoding read is ignored (-profile tcl8)} -setup { set fn [makeFile {} io-75.3] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f "A\xC0" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none + fconfigure $f -encoding utf-8 -buffering none -profile tcl8 } -body { set d [read $f] - close $f binary scan $d H* hd set hd } -cleanup { + close $f removeFile io-75.3 -} -result "41c0" +} -result 41c0 # As utf-8 has a special treatment in multi-byte decoding, also test another # one. -test io-75.4 {shiftjis encoding error read results in raw bytes} -setup { +test io-75.4 {shiftjis encoding error read results in raw bytes (-profile tcl8)} -setup { set fn [makeFile {} io-75.4] set f [open $fn w+] fconfigure $f -encoding binary # In shiftjis, \x81 starts a two-byte sequence. # But 2nd byte \xFF is not allowed - puts -nonewline $f "A\x81\xFFA" + puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -profile tcl8 } -body { set d [read $f] binary scan $d H* hd @@ -8905,29 +9174,419 @@ test io-75.4 {shiftjis encoding error read results in raw bytes} -setup { } -cleanup { close $f removeFile io-75.4 -} -result "4181ff41" +} -result 4181ff41 -test io-75.5 {incomplete shiftjis encoding read is ignored} -setup { +test io-75.5 {invalid utf-8 encoding read is ignored (-profile tcl8)} -setup { set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 announces a two byte sequence. - puts -nonewline $f "A\x81" + puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile tcl8 } -body { set d [read $f] - close $f binary scan $d H* hd set hd } -cleanup { + close $f removeFile io-75.5 -} -result "4181" +} -result 4181 + +test io-75.6 {invalid utf-8 encoding, gets is not ignored (-profile strict)} -setup { + set fn [makeFile {} io-75.6] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is an incomplete byte sequence in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ + -translation lf -profile strict +} -body { + gets $f +} -cleanup { + close $f + removeFile io-75.6 +} -match glob -returnCodes 1 -result {error reading "file*":\ + invalid or incomplete multibyte or wide character} + +test io-75.7 { + invalid utf-8 encoding gets is not ignored (-profile strict) +} -setup { + set fn [makeFile {} io-75.7] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ + -profile strict +} -body { + list [catch {read $f} msg] $msg +} -cleanup { + close $f + removeFile io-75.7 + unset msg f fn +} -match glob -result {1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} + +test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup { + set fn [makeFile {} io-75.8] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes + # precedence. + puts -nonewline $f A\x1A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ + -translation lf -profile strict +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [eof $f] + lappend hd [read $f] + close $f + set hd +} -cleanup { + removeFile io-75.8 +} -result {41 1 {}} + +test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -setup { + set fn [makeFile {} io-75.8] + set f [open $fn w+] + # This also configures the channel encoding profile as strict. + fconfigure $f -encoding binary + # \x81 is invalid in utf-8. -eofchar is not detected, because it comes later. + puts -nonewline $f A\x81\x81\x1A + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ + -translation lf -profile strict +} -body { + set res [list [catch {read $f} msg] [eof $f]] + chan configure $f -encoding iso8859-1 + lappend res [read $f 1] + chan configure $f -encoding utf-8 + lappend res [catch {read $f 1} msg] $msg +} -cleanup { + close $f + removeFile io-75.8 + unset res msg fn f +} -match glob -result "1 0 \x81 1 {error reading \"*\":\ + invalid or incomplete multibyte or wide character}" + + +test io-strict-multibyte-eof { + incomplete utf-8 sequence immediately prior to eof character + + See issue 25cdcb7e8fb381fb +} -setup { + set chan [file tempfile]; + fconfigure $chan -encoding binary + puts -nonewline $chan \x81\x1A + flush $chan + seek $chan 0 + chan configure $chan -encoding utf-8 -profile strict +} -body { + list [catch {read $chan 1} msg] $msg +} -cleanup { + close $chan + unset msg chan +} -match glob -result {1 {error reading "*":\ + invalid or incomplete multibyte or wide character}} + +test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { + set fn [makeFile {} io-75.9] + set f [open $fn w+] + fconfigure $f -encoding iso8859-1 -profile strict +} -body { + catch {puts -nonewline $f "A\u2022"} msg + flush $f + seek $f 0 + list [read $f] $msg +} -cleanup { + close $f + removeFile io-75.9 + unset f +} -match glob -result [list {A} {error writing "*":\ + invalid or incomplete multibyte or wide character}] + +# Incomplete sequence test. +# This error may IMHO only be detected with the close. +# But the read already returns the incomplete sequence. +test io-75.10 {incomplete multibyte encoding read is ignored} -setup { + set fn [makeFile {} io-75.10] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\xC0 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none +} -body { + set d [read $f] + binary scan $d H* hd + set hd +} -cleanup { + close $f + removeFile io-75.10 + unset d hd +} -result 41c0 +# The current result returns the orphan byte as byte. +# This may be expected due to special utf-8 handling. + +# As utf-8 has a special treatment in multi-byte decoding, also test another +# one. +test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { + set fn [makeFile {} io-75.11] + set f [open $fn w+] + fconfigure $f -encoding binary + # In shiftjis, \x81 starts a two-byte sequence. + # But 2nd byte \xFF is not allowed + puts -nonewline $f A\x81\xFFA + flush $f + seek $f 0 + fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \ + -profile strict +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {set d [read $f]} msg] $msg +} -cleanup { + close $f + removeFile io-75.11 + unset d hd msg f +} -match glob -result {41 1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} + +test io-75.12 {invalid utf-8 encoding read is ignored} -setup { + set fn [makeFile {} io-75.12] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf +} -body { + set d [read $f] + binary scan $d H* hd + set hd +} -cleanup { + close $f + removeFile io-75.12 +} -result 4181 +test io-75.13 { + In nonblocking mode when there is an encoding error the data that has been + successfully read so far is returned first and then the error is returned + on the next call to [read]. +} -setup { + set fn [makeFile {} io-75.13] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \ + -profile strict +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {read $f} msg] $msg +} -cleanup { + close $f + removeFile io-75.13 + unset d hd msg f fn +} -match glob -result {41 1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} + +test io-75.14 { + [gets] succesfully returns lines prior to error + invalid utf-8 encoding [gets] continues in non-strict mode after error +} -setup { + set chan [file tempfile] + fconfigure $chan -encoding binary + # \xC0\n is an invalid utf-8 sequence + puts -nonewline $chan a\nb\nc\xC0\nd\n + flush $chan + seek $chan 0 + fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \ + -translation auto -profile strict +} -body { + set res [gets $chan] + lappend res [gets $chan] + lappend res [catch {gets $chan} msg] $msg + chan configure $chan -profile tcl8 + lappend res [gets $chan] + lappend res [gets $chan] + return $res +} -cleanup { + close $chan + unset chan res msg +} -match glob -result {a b 1 {error reading "*":\ + invalid or incomplete multibyte or wide character} cÀ d} + +test io-75.15 { + invalid utf-8 encoding strict + gets does not hang + gets succeeds for the first two lines +} -setup { + set res {} + set chan [file tempfile] + fconfigure $chan -encoding binary + # \xC0\x40 is an invalid utf-8 sequence + puts $chan hello\nAB\nCD\xC0\x40EF\nGHI + seek $chan 0 +} -body { + #Now try to read it with [gets] + fconfigure $chan -encoding utf-8 -profile strict + lappend res [gets $chan] + lappend res [gets $chan] + lappend res [catch {gets $chan} msg] $msg + lappend res [catch {gets $chan} msg] $msg + chan configure $chan -translation binary + set data [read $chan 4] + foreach char [split $data {}] { + scan $char %c ord + lappend res [format %x $ord] + } + fconfigure $chan -encoding utf-8 -profile strict -translation auto + lappend res [gets $chan] + lappend res [gets $chan] + return $res +} -cleanup { + close $chan + unset chan res msg data +} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\ + 1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI} # ### ### ### ######### ######### ######### + + +test io-76.0 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {read {}} + +test io-76.1 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {{} write} + +test io-76.2 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {read write} + +test io-76.3 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mremove-wr $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{read {}} {read {}}} + +test io-76.4 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mremove-rd $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} + +test io-76.5 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mremove-rd $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{{} write} {{} write}} + +test io-76.6 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mremove-wr $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} + +test io-76.7 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-rd $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{{} write} {read write}} + +test io-76.8 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-wr $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{read {}} {read write}} + +test io-76.9 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-wr $f + testchannel mremove-rd $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} + +test io-76.10 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-rd $f + testchannel mremove-wr $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} + # cleanup foreach file [list fooBar longfile script script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dae15af..678700f 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -6,9 +6,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-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. @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { source [file join [file dirname [info script]] tcltests.tcl] ::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]] @@ -153,10 +153,10 @@ test iocmd-4.11 {read command} { test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek @@ -205,83 +205,95 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.2 {fconfigure command} { - list [catch {fconfigure a b c d e f} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +proc expectedOpts {got extra} { + set basicOpts { + -blocking -buffering -buffersize -encoding -eofchar -profile -translation + } + set opts [list {*}$basicOpts {*}$extra] + lset opts end [string cat "or " [lindex $opts end]] + return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] +} +test iocmd-8.1 {fconfigure command} -returnCodes error -body { + fconfigure +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.2 {fconfigure command} -returnCodes error -body { + fconfigure a b c d e f +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.3 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} +test iocmd-8.4 {fconfigure command} -setup { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] +} -body { + fconfigure $f1 froboz +} -returnCodes error -cleanup { close $f1 - set x -} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.5 {fconfigure command} { - list [catch {fconfigure stdin -buffering froboz} msg] $msg -} {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-8.6 {fconfigure command} { - list [catch {fconfigure stdin -translation froboz} msg] $msg -} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-8.7 {fconfigure command} { +} -result [expectedOpts "froboz" -stat] +test iocmd-8.5 {fconfigure command} -returnCodes error -body { + fconfigure stdin -buffering froboz +} -result {bad value for -buffering: must be one of full, line, or none} +test iocmd-8.6 {fconfigure command} -returnCodes error -body { + fconfigure stdin -translation froboz +} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} +test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -profile tcl8 + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf} +test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) + set x {} +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding unicode - set x "" + -eofchar {} -encoding utf-16 -profile tcl8 lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] - close $f1 - set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +} -cleanup { + catch {close $f1} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}} +test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} + -eofchar {} -encoding binary -profile tcl8 + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -profile tcl8 -translation lf} +test iocmd-8.10 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.12 {fconfigure command} { + fconfigure $chan -froboz blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-froboz" {}] +test iocmd-8.12 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.13 {fconfigure command} { + fconfigure $chan -b blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-b" {}] +test iocmd-8.13 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} + fconfigure $chan -buffer blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-buffer" {}] removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { +test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} @@ -293,7 +305,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} +} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nodelay -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -336,7 +348,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { @@ -347,9 +359,40 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] +test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -blah blih +} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). +test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints { + deprecated obsolete +} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -nocomplainencoding 0 +} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" +test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { + set console stdin + set oldprofile [fconfigure $console -profile] +} -constraints { + obsolete +} -body { + fconfigure $console -strictencoding 1 + fconfigure $console -nocomplainencoding 0 + fconfigure $console -nocomplainencoding +} -cleanup { + fconfigure $console -strictencoding $oldmode +} -result 0 + + +test iocmd-8.23 {fconfigure -profile badprofile} -body { + fconfigure stdin -profile froboz +} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8} test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode @@ -475,14 +518,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 @@ -563,7 +606,28 @@ test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { } -cleanup { removeFile $f } -result 341234x6 - +test ioCmd-13.12 {open file produces something that has fconfigure -stat} -setup { + set f [makeFile {} iocmd13_12] + set result {} +} -body { + set fd [open $f wb] + set result [dict get [fconfigure $fd -stat] type] + fconfigure $fd -buffering none + puts -nonewline $fd abc + # Three ways of getting the size; all should agree! + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + puts -nonewline $fd def + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + puts -nonewline $fd ghi + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + close $fd + return $result +} -cleanup { + removeFile $f +} -result {file 3 3 3 6 6 6 9 9 9} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode @@ -911,6 +975,17 @@ proc onfinal {} { if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } + +proc onwatch {} { + upvar args hargs + lassign $hargs watch chan eventspec + if {$watch ne "watch"} return + foreach spec $eventspec { + chan postevent $chan $spec + } + return +} + } # Set everything up in the main thread. @@ -1018,7 +1093,7 @@ test iocmd-23.1 {chan read, regular data return} -match glob -body { rename foo {} set res } -result {{read rc* 4096} {read rc* 4096} snarfsnarf} -test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { +test iocmd-23.2 {chan read, bad data return, too much} -match glob -body { set res {} proc foo {args} { oninit; onfinal; track @@ -1333,7 +1408,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1342,7 +1417,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1354,7 +1429,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { @@ -1983,28 +2058,29 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c readable {note TOCK}] - set stop [after 15000 {note TIMEOUT}] + set tock {} + note [fileevent $c readable {lappend res TOCK; set tock 1}] + set stop [after 15000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c r]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* read} {} {} TOCK {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {note TOCK}] - set stop [after 15000 {note TIMEOUT}] + note [fileevent $c writable {lappend res TOCK; set tock 1}] + set stop [after 15000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c w]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* write} {} {} TOCK {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } @@ -2017,6 +2093,31 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { rename foo {} rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} +test iocmd-31.9 { + chan postevent + + call to current coroutine + + see 67a5eabbd3d1 +} -match glob -body { + set res {} + proc foo {args} {oninit; onwatch; onfinal; track; return} + set c [chan create {r w} foo] + after 0 [list ::apply [list c { + coroutine c1 ::apply [list c { + chan event $c readable [list [info coroutine]] + yield + set ::done READING + } [namespace current]] $c + } [namespace current]] $c] + set stop [after 10000 {set done TIMEOUT}] + vwait ::done + catch {after cancel $stop} + lappend res $done + close $c + rename foo {} + set res +} -result {{watch rc* read} READING {watch rc* {}}} # --- === *** ########################### # 'Pull the rug' tests. Create channel in a interpreter A, move to @@ -2303,7 +2404,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { rename foo {} set res } -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} -test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { +test iocmd.tf-23.2 {chan read, bad data return, too much} -match glob -body { set res {} proc foo {args} { oninit; onfinal; track @@ -2849,7 +2950,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body rename foo {} set res } -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2862,7 +2963,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2878,7 +2979,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 4eafb6b..45d2530 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -5,7 +5,7 @@ # 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 @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] diff --git a/tests/iogt.test b/tests/iogt.test index 68f9a5c..5692682 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 9ea554d..3573fbd 100644 --- a/tests/join.test +++ b/tests/join.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. diff --git a/tests/lindex.test b/tests/lindex.test index 0b8c327..ffe0d9e 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -4,10 +4,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-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. @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] set minus - testConstraint testevalex [llength [info commands testevalex]] @@ -51,22 +51,22 @@ test lindex-2.4 {malformed index list} testevalex { # Indices that are integers or convertible to integers -test lindex-3.1 {integer -1} testevalex { +test lindex-3.1 {integer -1} -constraints testevalex -body { set x ${minus}1 list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {{} {}} -test lindex-3.2 {integer 0} testevalex { +} -result {{} {}} +test lindex-3.2 {integer 0} -constraints testevalex -body { set x [string range 00 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {a a} -test lindex-3.3 {integer 2} testevalex { +} -result {a a} +test lindex-3.3 {integer 2} -constraints testevalex -body { set x [string range 22 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {c c} -test lindex-3.4 {integer 3} testevalex { +} -result {c c} +test lindex-3.4 {integer 3} -constraints testevalex -body { set x [string range 33 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {{} {}} +} -result {{} {}} test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result @@ -75,19 +75,19 @@ test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result } -match glob -result {1 {*invalid octal number*}} -test lindex-3.7 {indexes don't shimmer wide ints} { +test lindex-3.7 {indexes don't shimmer wide ints} -body { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] -} {2147483646 {} 2147483647 2147483648} -test lindex-3.8 {compiled with static indices out of range, negative} { +} -result {2147483646 {} 2147483647 2147483648} +test lindex-3.8 {compiled with static indices out of range, negative} -body { list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3] -} [lrepeat 3 {}] -test lindex-3.9 {compiled with calculated indices out of range, negative constant} { +} -result [lrepeat 3 {}] +test lindex-3.9 {compiled with calculated indices out of range, negative constant} -body { list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1] -} [lrepeat 3 {}] -test lindex-3.10 {compiled with calculated indices out of range, after end} { +} -result [lrepeat 3 {}] +test lindex-3.10 {compiled with calculated indices out of range, after end} -body { list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3] -} [lrepeat 3 {}] +} -result [lrepeat 3 {}] # Indices relative to end @@ -165,34 +165,38 @@ test lindex-7.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} -test lindex-8.1 {data reuse} testevalex { +test lindex-8.1 {data reuse} -constraints testevalex -body { set x 0 testevalex {lindex $x $x} -} {0} -test lindex-8.2 {data reuse} testevalex { +} -result 0 +test lindex-8.2 {data reuse} -constraints testevalex -body { set a 0 testevalex {lindex $a $a $a} -} 0 -test lindex-8.3 {data reuse} testevalex { +} -result 0 +test lindex-8.3 {data reuse} -constraints { + testevalex +} -body { set a 1 testevalex {lindex $a $a $a} -} {} -test lindex-8.4 {data reuse} testevalex { +} -result {} +test lindex-8.4 {data reuse} -constraints testevalex -body { set x [list 0 0] testevalex {lindex $x $x} -} {0} -test lindex-8.5 {data reuse} testevalex { +} -result 0 +test lindex-8.5 {data reuse} -constraints testevalex -body { set x 0 testevalex {lindex $x [list $x $x]} -} {0} -test lindex-8.6 {data reuse} testevalex { +} -result 0 +test lindex-8.6 {data reuse} -constraints testevalex -body { set x [list 1 1] testevalex {lindex $x $x} -} {} -test lindex-8.7 {data reuse} testevalex { +} -result {} +test lindex-8.7 {data reuse} -constraints { + testevalex +} -body { set x 1 testevalex {lindex $x [list $x $x]} -} {} +} -result {} #---------------------------------------------------------------------- @@ -381,79 +385,76 @@ test lindex-15.3 {quoted elements} { } result set result } {c d " x} -test lindex-15.4 {quoted elements} { +test lindex-15.4 {quoted elements} -body { catch { lindex {a b {c d "e} {f g"}} 2 } result set result -} {c d "e} +} -result {c d "e} -test lindex-16.1 {data reuse} { +test lindex-16.1 {data reuse} -body { set x 0 catch { lindex $x $x } result set result -} {0} -test lindex-16.2 {data reuse} { +} -result {0} +test lindex-16.2 {data reuse} -body { set a 0 catch { lindex $a $a $a } result set result -} 0 -test lindex-16.3 {data reuse} { +} -result 0 +test lindex-16.3 {data reuse} -body { set a 1 catch { lindex $a $a $a } result set result -} {} -test lindex-16.4 {data reuse} { +} -result {} +test lindex-16.4 {data reuse} -body { set x [list 0 0] catch { lindex $x $x } result set result -} {0} -test lindex-16.5 {data reuse} { +} -result {0} +test lindex-16.5 {data reuse} -body { set x 0 catch { lindex $x [list $x $x] } result set result -} {0} -test lindex-16.6 {data reuse} { +} -result {0} +test lindex-16.6 {data reuse} -body { set x [list 1 1] catch { lindex $x $x } result set result -} {} -test lindex-16.7 {data reuse} { +} -result {} +test lindex-16.7 {data reuse} -body { set x 1 catch { lindex $x [list $x $x] } result set result -} {} - -test lindex-17.0 {Bug 1718580} {*}{ - -body { - lindex {} end foo - } - -match glob - -result {bad index "foo"*} - -returnCodes 1 -} - -test lindex-17.1 {Bug 1718580} {*}{ - -body { - lindex a end foo - } - -match glob - -result {bad index "foo"*} - -returnCodes 1 +} -result {} + +test lindex-17.0 {Bug 1718580} -body { + lindex {} end foo +} -match glob -result {bad index "foo"*} -returnCodes 1 +test lindex-17.1 {Bug 1718580} -body { + lindex a end foo +} -match glob -result {bad index "foo"*} -returnCodes 1 + +test lindex-18.0 {nested bytecode execution} -setup { + proc demo {i} {lindex {a b c} $i} +} -body { + demo 0+0x10000000000000000 +} -cleanup { + rename demo {} } catch { unset minus } diff --git a/tests/link.test b/tests/link.test index d37f08a..6ac2277 100644 --- a/tests/link.test +++ b/tests/link.test @@ -4,9 +4,9 @@ # 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. @@ -17,9 +17,10 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlink [llength [info commands testlink]] +testConstraint testlinkarray [llength [info commands testlinkarray]] foreach i {int real bool string} { unset -nocomplain $i @@ -68,9 +69,9 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup { set long 34543 set ulong 567890 set float 1.0987654321 - set uwide 357357357357 + set uwide 12345678901234567890 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 12345678901234567890 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} test link-2.2 {writing bad values into variables} -setup { testlink delete } -constraints {testlink} -body { @@ -98,7 +99,7 @@ test link-2.5 {writing bad values into variables} -setup { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool -} -result {1 {can't set "wide": variable must have integer value} 1} +} -result {1 {can't set "wide": variable must have wide integer value} 1} test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { @@ -183,6 +184,27 @@ test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup { set uwide 0 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0} +test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "0x" + set real "0b" + set bool 0 + set string "0" + set wide "0D" + set char "0X" + set uchar "0B" + set short "0D" + set ushort "0x" + set uint "0b" + set long "0d" + set ulong "0X" + set float "0B" + set uwide "0D" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D} test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete @@ -352,7 +374,7 @@ test link-7.7 {access to linked variables via upvar} -setup { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $wide -} -result {1 {can't set "y": variable must have integer value} 778899} +} -result {1 {can't set "y": variable must have wide integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { @@ -362,11 +384,11 @@ test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { set x {} testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 - trace var int w x + trace add var int write x testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 - trace vdelete int w x + trace remove var int write x return $x -} {{int {} w} 32 -2.0 0 xyzzy 995511} +} {{int {} write} 32 -2.0 0 xyzzy 995511} test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide @@ -376,9 +398,9 @@ test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete - trace var int w x + trace add var int write x testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 - trace vdelete int w x + trace remove var int write x return $x } {} test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { @@ -387,6 +409,477 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} } msg] $msg $int } {0 {} 47} + +test link-9.1 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray +} -result {wrong # args: should be "testlinkarray option args"} +test link-9.2 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray x +} -result {bad option "x": must be update, remove, or create} +test link-9.3 {linkarray usage messages} -constraints testlinkarray -body { + testlinkarray update +} -result {} +test link-9.4 {linkarray usage messages} -constraints testlinkarray -body { + testlinkarray remove +} -result {} +test link-9.5 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create +} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"} +test link-9.6 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create xx 1 my +} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary} +test link-9.7 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create char* 0 my +} -result {wrong array size given} + +test link-10.1 {linkarray char*} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char* 1 ::my(var) + lappend mylist [set ::my(var) ""] + catch {set ::my(var) x} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} {can't set "::my(var)": wrong size of char* value}} +test link-10.2 {linkarray char*} -constraints testlinkarray -body { + testlinkarray create char* 4 ::my(var) + set ::my(var) x + catch {set ::my(var) xyzz} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of char* value} +test link-10.3 {linkarray char*} -constraints testlinkarray -body { + testlinkarray create -r char* 4 ::my(var) + catch {set ::my(var) x} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-11.1 {linkarray char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1234} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}} +test link-11.2 {linkarray char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-11.3 {linkarray char} -constraints testlinkarray -body { + testlinkarray create -r char 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-12.1 {linkarray unsigned char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uchar 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1234} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}} +test link-12.2 {linkarray unsigned char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uchar 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-12.3 {linkarray unsigned char} -constraints testlinkarray -body { + testlinkarray create -r uchar 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-13.1 {linkarray short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create short 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 123456} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}} +test link-13.2 {linkarray short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create short 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-13.3 {linkarray short} -constraints testlinkarray -body { + testlinkarray create -r short 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-14.1 {linkarray unsigned short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ushort 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 123456} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}} +test link-14.2 {linkarray unsigned short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ushort 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-14.3 {linkarray unsigned short} -constraints testlinkarray -body { + testlinkarray create -r ushort 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-15.1 {linkarray int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create int 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e3} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}} +test link-15.2 {linkarray int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create int 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-15.3 {linkarray int} -constraints testlinkarray -body { + testlinkarray create -r int 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-16.1 {linkarray unsigned int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uint 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}} +test link-16.2 {linkarray unsigned int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uint 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-16.3 {linkarray unsigned int} -constraints testlinkarray -body { + testlinkarray create -r uint 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-17.1 {linkarray long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create long 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}} +test link-17.2 {linkarray long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create long 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-17.3 {linkarray long} -constraints testlinkarray -body { + testlinkarray create -r long 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-18.1 {linkarray unsigned long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ulong 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} +test link-18.2 {linkarray unsigned long} -constraints testlinkarray -body { + testlinkarray create ulong 1 ::my(var) + set ::my(var) 120 + catch {set ::my(var) -1} msg + return $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned * value} +test link-18.3 {linkarray unsigned long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ulong 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-18.4 {linkarray unsigned long} -constraints testlinkarray -body { + testlinkarray create -r ulong 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-19.1 {linkarray wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create wide 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}} +test link-19.2 {linkarray wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create wide 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-19.3 {linkarray wide} -constraints testlinkarray -body { + testlinkarray create -r wide 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-20.1 {linkarray unsigned wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uwide 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg + lappend mylist [set ::my(var) 0xbabed00dbabed00d] +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d} +test link-20.2 {linkarray unsigned wide} -constraints testlinkarray -body { + testlinkarray create uwide 1 ::my(var) + set ::my(var) 120 + catch {set ::my(var) -1} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value} +test link-20.3 {linkarray unsigned wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uwide 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-20.4 {linkarray unsigned wide} -constraints testlinkarray -body { + testlinkarray create -r uwide 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-21.1 {linkarray string} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create string 1 ::my(var) + lappend mylist [set ::my(var) ""] + lappend mylist [set ::my(var) "xyz"] + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} xyz xyz} +test link-21.2 {linkarray string} -constraints testlinkarray -body { + testlinkarray create -r string 4 ::my(var) + catch {set ::my(var) x} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-22.1 {linkarray binary} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create binary 1 ::my(var) + set ::my(var) x + catch {set ::my(var) xy} msg + lappend mylist $msg + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} x} +test link-22.2 {linkarray binary} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create binary 4 ::my(var) + catch {set ::my(var) abc} msg + lappend mylist $msg + catch {set ::my(var) abcde} msg + lappend mylist $msg + set ::my(var) abcd + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd} +test link-22.3 {linkarray binary} -constraints testlinkarray -body { + testlinkarray create -r binary 4 ::my(var) + catch {set ::my(var) xyzv} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} diff --git a/tests/linsert.test b/tests/linsert.test index ddc56a9..16ade39 100644 --- a/tests/linsert.test +++ b/tests/linsert.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. diff --git a/tests/list.test b/tests/list.test index 864fad0..905a3d3 100644 --- a/tests/list.test +++ b/tests/list.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. @@ -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 diff --git a/tests/listObj.test b/tests/listObj.test index d60f13f..55fc089 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -5,8 +5,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) 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. @@ -17,9 +17,10 @@ if {"::tcltest" ni [namespace children]} { } ::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 memory [llength [info commands memory]] catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { @@ -210,6 +211,106 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj testobj bug3598580 } 123 +# Stolen from dict.test +proc listobjmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} +} + +test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + +test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + +# Tests for Tcl_ListObjIndex as sematics are different from lindex for +# out of bounds indices. Out of bounds should return a null pointer and +# not empty string. +test listobj-14.1 {Tcl_ListObjIndex out-of-bounds index for native lists} -constraints { + testobj +} -setup { + testobj set 1 [list a b c] +} -cleanup { + testobj freeallvars +} -body { + list [testlistobj index 1 -1] [testlistobj index 1 3] +} -result {null null} + +test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with spans} -constraints { + testobj +} -setup { + testobj set 1 [testlistrep new 1000 100 100] +} -cleanup { + testobj freeallvars +} -body { + list [testlistobj index 1 -1] [testlistobj index 1 1000] +} -result {null null} + +test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints { + testobj +} -setup { + testobj set 1 [lseq 3] +} -cleanup { + testobj freeallvars +} -body { + list [testlistobj index 1 -1] [testlistobj index 1 3] +} -result {null null} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/listRep.test b/tests/listRep.test new file mode 100644 index 0000000..02ff18f --- /dev/null +++ b/tests/listRep.test @@ -0,0 +1,2538 @@ +# This file contains tests that specifically exercise the internal representation +# of a list. +# +# Copyright © 2022 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Unlike the other files related to list commands which for the most part do +# black box testing focusing on functionality, this file does more of white box +# testing to exercise code paths that implement different list representations +# (with spans, leading free space etc., shared/unshared etc.) In addition to +# functional correctness, the tests also check for the expected internal +# representation as that pertains to performance heuristics. Generally speaking, +# combinations of the following need to be tested, +# - free space in front, back, neither, both of list representation +# - shared Tcl_Objs +# - shared internal reps (independent of shared Tcl_Objs) +# - byte-compiled vs non-compiled +# +# Being white box tests, they are sensitive to changes to further optimizations +# and changes in heuristics. That cannot be helped. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + +testConstraint testlistrep [llength [info commands testlistrep]] + +proc describe {l args} {dict get [testlistrep describe $l] {*}$args} + +proc irange {first last} { + set l {} + while {$first <= $last} { + lappend l $first + incr first + } + return $l +} +proc leadSpace {l} { + # Returns the leading space in a list store + return [dict get [describe $l] store firstUsed] +} +proc tailSpace {l} { + # Returns the trailing space in a list store + array set rep [describe $l] + dict with rep(store) { + return [expr {$numAllocated - ($firstUsed + $numUsed)}] + } +} +proc allocated {l} { + # Returns the allocated space in a list store + return [dict get [describe $l] store numAllocated] +} +proc repStoreRefCount {l} { + # Returns the ref count for the list store + return [dict get [describe $l] store refCount] +} +proc validate {l} { + # Panics if internal listrep structures are not valid + testlistrep validate $l +} +proc leadSpaceMore {l} { + set leadSpace [leadSpace $l] + expr {$leadSpace > 0 && $leadSpace >= 2*[tailSpace $l]} +} +proc tailSpaceMore {l} { + set tailSpace [tailSpace $l] + expr {$tailSpace > 0 && $tailSpace >= 2*[leadSpace $l]} +} +proc spaceEqual {l} { + # 1 if lead and tail space shared (diff of 1 at most) and more than 0 + set leadSpace [leadSpace $l] + set tailSpace [tailSpace $l] + if {$leadSpace == 0 && $tailSpace == 0} { + # At least one must be positive + return 0 + } + set diff [expr {$leadSpace - $tailSpace}] + return [expr {$diff >= -1 && $diff <= 1}] +} +proc storeAddress {l} { + return [describe $l store memoryAddress] +} +proc sameStore {l1 l2} { + expr {[storeAddress $l1] == [storeAddress $l2]} +} +proc hasSpan {l args} { + # Returns 1 if list has a span. If args are specified, they are checked with + # span values (start and length) + array set rep [describe $l] + if {![info exists rep(span)]} { + return 0 + } + if {[llength $args] == 0} { + return 1; # No need to check values + } + lassign $args start len + if {[dict get $rep(span) spanStart] == $start && + [dict get $rep(span) spanLength] == $len} { + return 1 + } + return 0 +} +proc checkListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Checks if the internal representation of $l match + # passed arguments. Return "" if yes, else error messages. + array set rep [testlistrep describe $l] + + set rep(leadSpace) [dict get $rep(store) firstUsed] + set rep(numAllocated) [dict get $rep(store) numAllocated] + set rep(tailSpace) [expr { + $rep(numAllocated) - ($rep(leadSpace) + [dict get $rep(store) numUsed]) + }] + set rep(refCount) [dict get $rep(store) refCount] + + if {[info exists rep(span)]} { + set rep(listLen) [dict get $rep(span) spanLength] + } else { + set rep(listLen) [dict get $rep(store) numUsed] + } + + set errors [list] + foreach arg {listLen numAllocated leadSpace tailSpace} { + if {$rep($arg) != [set $arg]} { + lappend errors "$arg in list representation ($rep($arg)) is not expected value ([set $arg])." + } + } + # Check refCount only if caller has specified it as non-0 + if {$refCount && $refCount != $rep(refCount)} { + lappend errors "refCount in list representation ($rep(refCount)) is not expected value ($refCount)." + } + return $errors +} + +proc assertListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Like check_listrep but raises error + set errors [checkListrep $l $listLen $numAllocated $leadSpace $tailSpace $refCount] + if {[llength $errors]} { + error [join $errors \n] + } + return +} + +# The default length should be large enough that doubling the allocation will +# clearly distinguish free space allocation difference between front and back. +# (difference in the two should at least be 2 else we cannot tell if front +# or back was favored appropriately) +proc freeSpaceNone {{len 8}} {return [testlistrep new $len 0 0]} +proc freeSpaceLead {{len 8} {lead 3}} {return [testlistrep new $len $lead 0]} +proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]} +proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} { + return [testlistrep new $len $lead $tail] +} +proc zombieSample {{len 1000} {leadzombies 100} {tailzombies 100}} { + # returns an unshared listrep with zombies in front and back + + # don't combine freespacenone and lrange else zombies are freed + set l [freeSpaceNone [expr {$len+$leadzombies+$tailzombies}]] + return [lrange $l $leadzombies [expr {$leadzombies+$len-1}]] +} + +# Just ensure above stubs return what's expected +if {[testConstraint testlistrep]} { + assertListrep [freeSpaceNone] 8 8 0 0 1 + assertListrep [freeSpaceLead] 8 11 3 0 1 + assertListrep [freeSpaceTail] 8 11 0 3 1 + assertListrep [freeSpaceBoth] 8 14 3 3 1 + assertListrep [zombieSample] 1000 1200 0 0 1 + if {![hasSpan [zombieSample]] || [dict get [testlistrep describe [zombieSample]] span spanStart] == 0} { + error "zombieSample span missing or span start is at 0." + } +} + +# Define some variables for some indices because the Tcl compiler will do some +# operations completely in byte code if indices are literals +set zero 0 +set one 1 +set two 2 +set four 4 +set end end + +# +# Test sets: +# 1.* - unshared internal rep, no spans, with no free space +# 2.* - shared internal rep, no spans, with no free space +# 3.* - unshared internal rep, spanned +# 4.* - shared internal rep, spanned +# 5.* - shared Tcl_Obj +# 6.* - lists with zombie Tcl_Obj's + +# +# listrep-1.* tests all operate on unshared listreps with no free space + +test listrep-1.1 { + Inserts in front of unshared list with no free space should reallocate with + equal free space at front and back -- linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $zero 99] + validate $l + list $l [spaceEqual $l] +} -result [list {99 0 1 2 3 4 5 6 7} 1] + +test listrep-1.1.1 { + Inserts in front of unshared list with no free space should reallocate with + equal free space at front and back -- lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero -1 99] + validate $l + list $l [spaceEqual $l] +} -result [list {99 0 1 2 3 4 5 6 7} 1] + +test listrep-1.2 { + Inserts at back of unshared list with no free space should allocate all + space at back -- linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $end 99] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.2.1 { + Inserts at back of unshared list with no free space should allocate all + space at back -- lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $end+1 99 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.2.2 { + Inserts at back of unshared list with no free space should allocate all + space at back -- lappend version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lappend l 99 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.3 { + Inserts in middle of unshared list with no free space should reallocate with + equal free space at front and back - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $four 99] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 99 4 5 6 7} 1] + +test listrep-1.3.1 { + Inserts in middle of unshared list with no free space should reallocate with + equal free space at front and back - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $four $four-1 99] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 99 4 5 6 7} 1] + +test listrep-1.4 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.1 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceNone] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.2 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set e [lpop l $zero] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.3 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone] $one $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.4.4 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone] $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.5 { + Deletes from front of large unshared list with no free space should + create a span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] +} -result [list [irange 2 999] 2 0 1] + +test listrep-1.5.1 { + Deletes from front of large unshared list with no free space should + create a span - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceNone 1000] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 0 [irange 1 999] 1 0 1] + +test listrep-1.5.2 { + Deletes from front of large unshared list with no free space should + create a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone 1000] $two end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] +} -result [list [irange 2 999] 2 0 1] + +test listrep-1.5.3 { + Deletes from front of large unshared list with no free space should + create a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone 1000] $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list [irange 1 999] 1 0 1] + +test listrep-1.5.4 { + Deletes from front of large unshared list with no free space should + create a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l 0] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 0 [irange 1 999] 1 0 1] + +test listrep-1.6 { + Deletes closer to front of large list should move (smaller) front segment + -- lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $four $four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list [concat [irange 0 3] [irange 5 999]] 1 0 1] + +test listrep-1.6.1 { + Deletes closer to front of large list should move (smaller) front segment + -- lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $four] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list 4 [concat [irange 0 3] [irange 5 999]] 1 0 1] + +test listrep-1.7 { + Deletes closer to back of large list should move (smaller) back segment + and will not need a span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end-$four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [concat [irange 0 994] [irange 996 999]] 0 1 0] + +test listrep-1.7.1 { + Deletes closer to back of large list should move (smaller) back segment + and will not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $end-4] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 995 [concat [irange 0 994] [irange 996 999]] 0 1 0] + +test listrep-1.8 { + Deletes at back of small unshared list should not need a span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] end-$one end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.8.1 { + Deletes at back of small unshared list should not need a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone] $zero end-$two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.8.2 { + Deletes at back of small unshared list should not need a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.8.3 { + Deletes at back of small unshared list should not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set e [lpop l $end] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 1 0] + +test listrep-1.9 { + Deletes at back of large unshared list should not need a span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.9.1 { + Deletes at back of large unshared list should not need a span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceNone 1000] 0 $end-5] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.9.2 { + Deletes at back of large unshared list should not need a span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceNone 1000] end-$four $end-3 end-$two $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.9.3 { + Deletes at back of large unshared list should not need a span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set e [lpop l $end] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 999 [irange 0 998] 0 1 0] + +test listrep-1.10 { + no-op on unshared list should force a canonical list string - lreplace version +} -body { + lreplace { 1 2 3 4 } $zero -1 +} -result {1 2 3 4} + +test listrep-1.10.1 { + no-op on unshared list should force a canonical list string - lrange version +} -body { + lrange { 1 2 3 4 } $zero $end +} -result {1 2 3 4} + +test listrep-1.11 { + Append elements to large unshared list is optimized as lappend + so no free space in front - lreplace version +} -constraints testlistrep -body { + # Note $end, not end else byte code compiler short-cuts + set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 1000] + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [irange 0 1000] 0 1 0] + +test listrep-1.11.1 { + Append elements to large unshared list is optimized as lappend + so no free space in front - linsert version +} -constraints testlistrep -body { + # Note $end, not end else byte code compiler short-cuts + set l [linsert [freeSpaceNone 1000] $end+1 1000] + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [irange 0 1000] 0 1 0] + +test listrep-1.11.2 { + Append elements to large unshared list leaves no free space in front + - lappend version +} -constraints testlistrep -body { + # Note $end, not end else byte code compiler short-cuts + set l [freeSpaceNone 1000] + lappend l 1000 1001 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [irange 0 1001] 0 1 0] + + +test listrep-1.12 { + Replacement of elements at front with same number elements in unshared list + is in-place - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $one 10 11] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 2 3 4 5 6 7} 0 0] + +test listrep-1.12.1 { + Replacement of elements at front with same number elements in unshared list + is in-place - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l 0 -1 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {-1 1 2 3 4 5 6 7} 0 0] + +test listrep-1.13 { + Replacement of elements at front with fewer elements in unshared list + results in a spanned list with space only in front +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $four 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 5 6 7} 4 0] + +test listrep-1.14 { + Replacement of elements at front with more elements in unshared list + results in a reallocated spanned list with space at front and back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $one 10 11 12] + validate $l + list $l [spaceEqual $l] +} -result [list {10 11 12 2 3 4 5 6 7} 1] + +test listrep-1.15 { + Replacement of elements in middle with same number elements in unshared list + is in-place - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $one $two 10 11] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 10 11 3 4 5 6 7} 0 0] + +test listrep-1.15.1 { + Replacement of elements in middle with same number elements in unshared list + is in-place - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $two -1 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 -1 3 4 5 6 7} 0 0] + +test listrep-1.16 { + Replacement of elements in front half with fewer elements in unshared list + results in a spanned list with space only in front since smaller segment moved +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $one $four 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 10 5 6 7} 3 0] + +test listrep-1.17 { + Replacement of elements in back half with fewer elements in unshared list + results in a spanned list with space only at back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] end-$four end-$one 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 10 7} 0 3] + +test listrep-1.18 { + Replacement of elements in middle more elements in unshared list + results in a reallocated spanned list with space at front and back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $one $two 10 11 12] + validate $l + list $l [spaceEqual $l] +} -result [list {0 10 11 12 3 4 5 6 7} 1] + +test listrep-1.19 { + Replacement of elements at back with same number elements in unshared list + is in-place - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $end-1 $end 10 11] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11} 0 0] + +test listrep-1.19.1 { + Replacement of elements at back with same number elements in unshared list + is in-place - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 10} 0 0] + +test listrep-1.20 { + Replacement of elements at back with fewer elements in unshared list + is in-place with space only at the back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $end-2 $end 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10} 0 2] + +test listrep-1.21 { + Replacement of elements at back with more elements in unshared list + allocates new representation with equal space at front and back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $end-1 $end 10 11 12] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 4 5 10 11 12} 1] + +# +# listrep-2.* tests all operate on shared list reps with no free space. Note the +# *list internal rep* must be shared, not only the Tcl_Obj so just assigning to +# another variable does not suffice. The lrange construct on an variable's value +# will do the needful. + +test listrep-2.1 { + Inserts in front of shared list with no free space should reallocate with + more leading space in front - linsert version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [linsert $b $zero 99] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] + +test listrep-2.1.1 { + Inserts in front of shared list with no free space should reallocate with + more leading space in front - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero -1 99] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] + +test listrep-2.2 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - linsert version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [linsert $b $end 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.2.1 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $end+1 end+$one 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.2.2 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lappend version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lappend b 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.2.3 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lset b $end+1 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 1 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.3 { + Inserts in middle of shared list with no free space should reallocate with + equal spacing - linsert version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [linsert $b $four 99] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] + +test listrep-2.3.1 { + Inserts in middle of shared list with no free space should reallocate with + equal spacing - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $four $four-1 99] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] + +test listrep-2.4 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero $zero] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.1 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $zero $one] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.2 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $one $end] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.3 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lassign version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lassign $b e] + validate $l + list $e [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 2 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.4.4 { + Deletes from front of small shared list with no free space should + allocate new list of exact size - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l $zero] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.5 { + Deletes from front of large shared list with no free space should + create span - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero $zero] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 1 999] 1 0 0 3] + +test listrep-2.5.1 { + Deletes from front of large shared list with no free space should + create span - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $zero $one] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 2 999] 1 0 0 3] + +test listrep-2.5.2 { + Deletes from front of large shared list with no free space should + create span - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $two $end] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 1 3 [irange 2 999] 1 0 0 3] + +test listrep-2.5.3 { + Deletes from front of large shared list with no free space should + create span - lassign version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lassign $b e] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list $e [sameStore $b $l] [repStoreRefCount $b] $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 1 3 [irange 1 999] 1 0 0 3] + +test listrep-2.5.4 { + Deletes from front of large shared list with no free space should + create span - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l $zero] + validate $l + # The listrep store should be shared among a, b, l (3 refs) + list $e $l [hasSpan $l] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 0 [irange 1 999] 1 0 0 2] + +test listrep-2.6 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $end $end] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6} 0 0 1] + +test listrep-2.6.1 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $end $end-1] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5} 0 0 1] + +test listrep-2.6.2 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $zero $end-1] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6} 0 0 1] + +test listrep-2.6.3 { + Deletes from back of small shared list with no free space should + allocate new list of exact size - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 0 1] + +test listrep-2.7 { + Deletes from back of large shared list with no free space should + use a span - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $end $end] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 998] 0 0 3] + +test listrep-2.7.1 { + Deletes from back of large shared list with no free space should + use a span - lremove version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lremove $b $end-1 $end] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 997] 0 0 3] + +test listrep-2.7.2 { + Deletes from back of large shared list with no free space should + use a span - lrange version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lrange $b $zero $end-1] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list [repStoreRefCount $b] $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 3 [irange 0 998] 0 0 3] + +test listrep-2.7.3 { + Deletes from back of large shared list with no free space should + use a span - lpop version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + set e [lpop l] + validate $l + # Note lead and tail space is 0 because original list store in a,b is used + list $e $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 999 [irange 0 998] 0 0 2] + +test listrep-2.8 { + no-op on shared list should force a canonical list representation + with original unchanged - lreplace version +} -body { + set l { 1 2 3 4 } + list [lreplace $l $zero -1] $l +} -result [list {1 2 3 4} { 1 2 3 4 }] + +test listrep-2.8.1 { + no-op on shared list should force a canonical list representation + with original unchanged - lrange version +} -body { + set l { 1 2 3 4 } + list [lrange $l $zero end] $l +} -result [list {1 2 3 4} { 1 2 3 4 }] + +test listrep-2.9 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $end+1 $end+1 1000] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list 2 [irange 0 1000] 0 1 1] + +test listrep-2.9.1 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - linsert version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [linsert $b $end+1 1000 1001] + validate $l + list [repStoreRefCount $b] $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list 2 [irange 0 1001] 0 1 1] + +test listrep-2.9.2 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - lappend version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + lappend l 1000 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list [irange 0 1000] 0 1 1] + +test listrep-2.9.3 { + Appends to back of large shared list with no free space allocates new + list with space only at the back - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone 1000] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $end+1 1000 + validate $l + list $l [leadSpace $l] [expr {[tailSpace $l]>0}] [repStoreRefCount $l] +} -result [list [irange 0 1000] 0 1 1] + +test listrep-2.10 { + Replacement of elements at front with same number in shared list results + in a new list store with more space in front than back - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero $one 10 11] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 11 2 3 4 5 6 7} 1 1] + +test listrep-2.10.1 { + Replacement of elements at front with same number in shared list results + in a new list store with no extra space - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $zero 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 1 2 3 4 5 6 7} 0 0 1] + +test listrep-2.11 { + Replacement of elements at front with fewer elements in shared list + results in a new list store with more space in front than back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero $four 10] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 5 6 7} 1 1] + +test listrep-2.12 { + Replacement of elements at front with more elements in shared list + results in a new spanned list with more space in front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $zero $one 10 11 12] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {10 11 12 2 3 4 5 6 7} 1 1] + +test listrep-2.13 { + Replacement of elements in middle with same number in shared list results + in a new list store with equal space in front and back - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $one $two 10 11] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 11 3 4 5 6 7} 1 1] + +test listrep-2.13.1 { + Replacement of elements in middle with same number in shared list results + in a new list store with exact allocation - lset version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $one 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 10 2 3 4 5 6 7} 0 0 1] + +test listrep-2.14 { + Replacement of elements in middle with fewer elements in shared list + results in a new list store with equal space +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $one 5 10] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 6 7} 1 1] + +test listrep-2.15 { + Replacement of elements in middle with more elements in shared list + results in a new spanned list with space in front and back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b $one $two 10 11 12] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 10 11 12 3 4 5 6 7} 1 1] + +test listrep-2.16 { + Replacement of elements at back with same number in shared list results + in a new list store with more space in back than front - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b end-$one $end 10 11] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 10 11} 1 1] + +test listrep-2.16.1 { + Replacement of elements at back with same number in shared list results + in a new list store with no extra - lreplace version +} -constraints testlistrep -body { + set a [freeSpaceNone] + set l [lrange $a $zero end]; # Ensure shared listrep + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 10} 0 0 1] + +test listrep-2.17 { + Replacement of elements at back with fewer elements in shared list + results in a new list store with more space in back than front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b end-$four $end 10] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 10} 1 1] + +test listrep-2.18 { + Replacement of elements at back with more elements in shared list + results in a new list store with more space in back than front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a $zero end]; # Ensure shared listrep + set l [lreplace $b end-$four $end 10] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 10} 1 1] + +# +# listrep-3.* - tests on unshared spanned listreps + +test listrep-3.1 { + Inserts in front of unshared spanned list with room in front should just + shrink the lead space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $zero -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 1 3 1] + +test listrep-3.1.1 { + Inserts in front of unshared spanned list with room in front should just + shrink the lead space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 1 3 1] + +test listrep-3.2 { + Inserts in front of unshared spanned list with insufficient room in front + but enough total freespace should redistribute free space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 10] $zero -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 5 4 1] + +test listrep-3.2.1 { + Inserts in front of unshared spanned list with insufficient room in front + but enough total freespace should redistribute free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 10] $zero -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -2 7] 5 4 1] + +test listrep-3.3 { + Inserts in front of unshared spanned list with insufficient total freespace + should reallocate with equal free space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -3 7] 6 5 1] + +test listrep-3.3.1 { + Inserts in front of unshared spanned list with insufficient total freespace + should reallocate with equal free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange -3 7] 6 5 1] + +test listrep-3.4 { + Inserts at back of unshared spanned list with room at back should not + reallocate - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $end 8] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 3 2 1] + +test listrep-3.4.1 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end+1 $end+1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 3 1 1] + +test listrep-3.4.2 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lappend l 8 9 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 3 0 1] + +test listrep-3.4.3 { + Inserts at back of unshared spanned list with room at back should not + reallocate - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 3 2 1] + +test listrep-3.5 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 10 1] $end 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.5.1 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 10 1] $end+1 $end+1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.5.2 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 10 1] + lappend l 8 9 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 9] 5 4 1] + +test listrep-3.5.3 { + Inserts at back of unshared spanned list with insufficient room in back + but enough total freespace should redistribute free space - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 10 0] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 5 4 1] + +test listrep-3.6 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc(). - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.6.1 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.6.2 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 8 1 1] + lappend l 8 9 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 10] 1 10 1] + +test listrep-3.6.3 { + Inserts in back of unshared spanned list with insufficient total freespace + should reallocate with all *additional* space at back. Note this differs + from the insert in front case because here we realloc() - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + lset l $end+1 8 + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 0 8] 0 9 1] + +test listrep-3.7 { + Inserts in front half of unshared spanned list with room in front should not + reallocate and should move front segment +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $one -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + +test listrep-3.8 { + Inserts in front half of unshared spanned list with insufficient leading + space but with enough tail space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 5] $one -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + +test listrep-3.8.1 { + Inserts in front half of unshared spanned list with insufficient leading + space but with enough tail space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 5] $one -1 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -2 -1 1 2 3 4 5 6 7} 1 3 1] + +test listrep-3.9 { + Inserts in front half of unshared spanned list with sufficient total + free space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 2 2] $one -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1] + +test listrep-3.9.1 { + Inserts in front half of unshared spanned list with sufficient total + free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 2 2] $one -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 0 1 1] + +test listrep-3.10 { + Inserts in front half of unshared spanned list with insufficient total space. + Note use of realloc() means new space will be at the back - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] + +test listrep-3.10.1 { + Inserts in front half of unshared spanned list with insufficient total space. + Note use of realloc() means new space will be at the back - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] + +test listrep-3.11 { + Inserts in back half of unshared spanned list with room in back should not + reallocate and should move back segment - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth] $end-$one 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.11.1 { + Inserts in back half of unshared spanned list with room in back should not + reallocate and should move back segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end -1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.12 { + Inserts in back half of unshared spanned list with insufficient tail + space but with enough leading space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 5 1] $end-$one 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.12.1 { + Inserts in back half of unshared spanned list with insufficient tail + space but with enough leading space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 5 1] $end -1 8 9] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 7} 3 1 1] + +test listrep-3.13 { + Inserts in back half of unshared spanned list with sufficient total + free space - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 2 2] $end-$one 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1] + +test listrep-3.13.1 { + Inserts in back half of unshared spanned list with sufficient total + free space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 2 2] $end -1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 0 1 1] + +test listrep-3.14 { + Inserts in back half of unshared spanned list with insufficient + total space. Note use of realloc() means new space will be at the + back - linsert version +} -constraints testlistrep -body { + set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] + +test listrep-3.14.1 { + Inserts in back half of unshared spanned list with insufficient + total space. Note use of realloc() means new space will be at the + back - lrepalce version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] + +test listrep-3.15 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.1 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {2 3 4 5 6 7} 0 8 0] + +test listrep-3.15.2 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth] $one $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.3 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceBoth] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 0 {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.15.4 { + Deletes from front of small unshared span list results in elements + moved up front and span removal - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + set e [lpop l $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {1 2 3 4 5 6 7} 0 7 0] + +test listrep-3.16 { + Deletes from front of large unshared span list results in another + span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.1 { + Deletes from front of large unshared span list results in another + span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.2 { + Deletes from front of large unshared span list results in another + span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth 1000 10 10] $two $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [irange 2 999] 12 10 1] + +test listrep-3.16.3 { + Deletes from front of large unshared span list results in another + span - lassign version +} -constraints testlistrep -body { + set l [lassign [freeSpaceBoth 1000 10 10] e] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999] +} -result [list 0 [irange 1 999] 11 10 1] + +test listrep-3.16.4 { + Deletes from front of large unshared span list results in another + span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set e [lpop l $zero] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 11 999] +} -result [list 0 [irange 1 999] 11 10 1] + +test listrep-3.17 { + Deletes from back of small unshared span list results in new store + without span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.17.1 { + Deletes from back of small unshared span list results in new store + without span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.17.2 { + Deletes from back of small unshared span list results in new store + without span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth] $zero $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.17.3 { + Deletes from back of small unshared span list results in new store + without span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list 7 {0 1 2 3 4 5 6} 0 7 0] + +test listrep-3.18 { + Deletes from back of large unshared span list results in another + span - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.18.1 { + Deletes from back of large unshared span list results in another + span - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $end-1 $end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.18.2 { + Deletes from back of large unshared span list results in another + span - lrange version +} -constraints testlistrep -body { + set l [lrange [freeSpaceBoth 1000 10 10] $zero $end-2] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [irange 0 997] 10 12 1] + +test listrep-3.18.3 { + Deletes from back of large unshared span list results in another + span - lpop version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set e [lpop l] + validate $l + list $e $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 999] +} -result [list 999 [irange 0 998] 10 11 1] + +test listrep-3.19 { + Deletes from front half of small unshared span list results in + movement of smaller front segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6] +} -result [list {0 3 4 5 6 7} 5 3 1] + +test listrep-3.19.1 { + Deletes from front half of small unshared span list results in + movement of smaller front segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 5 6] +} -result [list {0 3 4 5 6 7} 5 3 1] + +test listrep-3.20 { + Deletes from front half of large unshared span list results in + movement of smaller front segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [list 0 {*}[irange 3 999]] 12 10 1] + +test listrep-3.20.1 { + Deletes from front half of large unshared span list results in + movement of smaller front segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $one $two] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 12 998] +} -result [list [list 0 {*}[irange 3 999]] 12 10 1] + +test listrep-3.21 { + Deletes from back half of small unshared span list results in + movement of smaller back segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6] +} -result [list {0 1 2 3 4 7} 3 5 1] + +test listrep-3.21.1 { + Deletes from back half of small unshared span list results in + movement of smaller back segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 3 6] +} -result [list {0 1 2 3 4 7} 3 5 1] + +test listrep-3.22 { + Deletes from back half of large unshared span list results in + movement of smaller back segment - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 1000 10 10] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [list {*}[irange 0 996] 999] 10 12 1] + +test listrep-3.22.1 { + Deletes from back half of large unshared span list results in + movement of smaller back segment - lremove version +} -constraints testlistrep -body { + set l [lremove [freeSpaceBoth 1000 10 10] $end-2 $end-1] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 10 998] +} -result [list [list {*}[irange 0 996] 999] 10 12 1] + +test listrep-3.23 { + Replacement of elements at front with same number elements in unshared + spanned list is in-place - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero $one 10 11] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 2 3 4 5 6 7} 3 3] + +test listrep-3.23.1 { + Replacement of elements at front with same number elements in unshared + spanned list is in-place - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lset l $zero 10 + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 1 2 3 4 5 6 7} 3 3] + +test listrep-3.24 { + Replacement of elements at front with fewer elements in unshared + spanned list expands leading space - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero $four 10] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 5 6 7} 7 3] + +test listrep-3.25 { + Replacement of elements at front with more elements in unshared + spanned list with sufficient leading space shrinks leading space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $zero $one 10 11 12] + list $l [leadSpace $l] [tailSpace $l] +} -result [list {10 11 12 2 3 4 5 6 7} 2 3] + +test listrep-3.26 { + Replacement of elements at front with more elements in unshared + spanned list with insufficient leading space but sufficient total + free space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 10] $zero $one 10 11 12 13] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 11 12 13 2 3 4 5 6 7} 5 4 1] + +test listrep-3.27 { + Replacement of elements at front in unshared spanned list with insufficient + total freespace should reallocate with equal free space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14] + validate $l + list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1] + +test listrep-3.28 { + Replacement of elements at back with same number of elements in unshared + spanned list is in-place - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-1 $end 10 11] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11} 3 3] + +test listrep-3.28.1 { + Replacement of elements at back with same number of elements in unshared + spanned list is in-place - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lset l $end 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 10} 3 3] + +test listrep-3.29 { + Replacement of elements at back with fewer elements in unshared + spanned list expands tail space +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-2 $end 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10} 3 5] + +test listrep-3.30 { + Replacement of elements at back with more elements in unshared + spanned list with sufficient tail space shrinks tailspace +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-1 $end 10 11 12] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12} 3 2] + +test listrep-3.31 { + Replacement of elements at back with more elements in unshared spanned list + with insufficient tail space but enough total free space moves up the span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 2 2] $end-1 $end 10 11 12 13 14] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 0 1] + +test listrep-3.32 { + Replacement of elements at back with more elements in unshared spanned list + with insufficient total space reallocates with more room in the tail because + of realloc() +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10] + +test listrep-3.33 { + Replacement of elements in the middle in an unshared spanned list with + the same number of elements - lreplace version +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $two $four 10 11 12] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 11 12 5 6 7} 3 3] + +test listrep-3.33.1 { + Replacement of elements in the middle in an unshared spanned list with + the same number of elements - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth] + lset l $two 10 + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 3 4 5 6 7} 3 3] + +test listrep-3.34 { + Replacement of elements in an unshared spanned list with fewer elements + in the front half moves the front (smaller) segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $two $four 10 11] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 10 11 5 6 7} 4 3] + +test listrep-3.35 { + Replacement of elements in an unshared spanned list with fewer elements + in the back half moves the tail (smaller) segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 10 7} 3 4] + +test listrep-3.36 { + Replacement of elements in an unshared spanned list with more elements + when both front and back have room should move the smaller segment + (front case) +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $one $two 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 3 4 5 6 7} 2 3] + +test listrep-3.37 { + Replacement of elements in an unshared spanned list with more elements + when both front and back have room should move the smaller segment + (back case) +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $end-2 $end-1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 8 9 10 7} 3 2] + +test listrep-3.38 { + Replacement of elements in an unshared spanned list with more elements + when only front has room +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 3 1] $end-1 $end-1 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 8 9 10 7} 1 1] + +test listrep-3.39 { + Replacement of elements in an unshared spanned list with more elements + when only back has room +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 3] $one $one 8 9 10] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 2 3 4 5 6 7} 1 1] + +test listrep-3.40 { + Replacement of elements in an unshared spanned list with more elements + when neither send has enough room by itself +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth] $one $one 8 9 10 11 12] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 1] + +test listrep-3.41 { + Replacement of elements in an unshared spanned list with more elements + when there is not enough free space results in new allocation. The back + end has more space because of realloc() +} -constraints testlistrep -body { + set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] + +# +# 4.* - tests on shared spanned lists + +test listrep-4.1 { + Inserts in front of shared spanned list with used elements in lead space + creates new list rep with more lead than tail space - linsert version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [linsert $spanl $zero -1] + validate $l + list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 999] [irange 2 997] [list -1 {*}[irange 2 997]] 1 1 2 2 1] + +test listrep-4.1.1 { + Inserts in front of shared spanned list with used elements in lead space + creates new list rep with more lead than tail space - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero -1 -2] + validate $l + list $master $spanl $l [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $master] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 999] [irange 2 997] [list -2 {*}[irange 2 997]] 1 1 2 2 1] + +test listrep-4.2 { + Inserts in front of shared spanned list with orphaned leading elements + allocate a new list rep with more lead than tail space - linsert version + TODO - ideally this should garbage collect the orphans and reuse the lead space + but that needs a "lprepend" command else the listrep operand is shared and hence + orphans cannot be freed +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $two $end-2] + unset master; # So elements at 0, 1 are not used + set l [linsert $spanl $zero -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [list -1 {*}[irange 2 997]] 0 1 1 1 1] + +test listrep-4.2.1 { + Inserts in front of shared spanned list with orphaned leading elements + allocate a new list rep with more lead than tail space - lreplace version + TODO - ideally this should garbage collect the orphans and reuse the lead space + but that needs a "lprepend" command else the listrep operand is shared and hence + orphans cannot be freed +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $two $end-2] + unset master; # So elements at 0, 1 are not used + set l [lreplace $spanl $zero -1 -2] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [list -2 {*}[irange 2 997]] 0 1 1 1 1] + +test listrep-4.3 { + Inserts in front of shared spanned list where span is at front of used + space reuses the same list store - linsert version +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $zero $end-2] + set l [linsert $spanl $zero -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3] + +test listrep-4.3.1 { + Inserts in front of shared spanned list where span is at front of used + space reuses the same list store - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceLead 1000 100] + set spanl [lrange $master $zero $end-2] + set l [lreplace $spanl $zero -1 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpace $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -1 997] 1 99 0 1 3 3] + +test listrep-4.4 { + Inserts in front of shared spanned list where span is at front of used + space allocates new listrep if lead space insufficient even if total free space + is sufficient. New listrep should have more lead space than tail space. + - linsert version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $zero $end-2] + set l [linsert $spanl $zero -3 -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1] + +test listrep-4.4.1 { + Inserts in front of shared spanned list where span is at front of used + space allocates new listrep if lead space insufficient even if total free space + is sufficient. New listrep should have more lead space than tail space. + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $zero $end-2] + set l [lreplace $spanl $zero -1 -3 -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 0 997] [irange -3 997] 0 1 1 2 1] + +test listrep-4.5 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - linsert version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end] + set l [linsert $spanl $end 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1] + +test listrep-4.5.1 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end] + set l [lreplace $spanl $end+1 $end+1 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 999] [irange 2 1000] 0 1 1 2 1] + +test listrep-4.5.2 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lappend version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set l [lrange $master $two $end] + lappend l 1000 + validate $l + list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [irange 2 1000] 0 1 1 1] + +test listrep-4.5.3 { + Inserts in back of shared spanned list where span is at end of used space + still allocates a new listrep and trailing space is more than leading space + - lset version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set l [lrange $master $two $end] + lset l $end+1 1000 + validate $l + list $l [sameStore $master $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [irange 2 1000] 0 1 1 1] + + +test listrep-4.6 { + Inserts in middle of shared spanned list allocates a new listrep with equal + lead and tail space - linsert version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end-2] + set i 200 + set l [linsert $spanl $i 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1] + +test listrep-4.6.1 { + Inserts in middle of shared spanned list allocates a new listrep with equal + lead and tail space - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceBoth 1000 2] + set spanl [lrange $master $two $end-2] + set i 200 + set l [lreplace $spanl $i -1 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 201] 1000 [irange 202 997]] 0 1 1 2 1] + +test listrep-4.7 { + Deletes from front of shared spanned list do not create a new allocation + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.7.1 { + Deletes from front of shared spanned list do not create a new allocation + - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lremove $spanl $zero $one] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.7.2 { + Deletes from front of shared spanned list do not create a new allocation + - lrange version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lrange $spanl $two $end] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 4 997] 1 1 3 3] + +test listrep-4.7.3 { + Deletes from front of shared spanned list do not create a new allocation + - lassign version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lassign $spanl e] + validate $l + list $e $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list 2 [irange 2 997] [irange 3 997] 1 1 3 3] + +test listrep-4.7.4 { + Deletes from front of shared spanned list do not create a new allocation + - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set e [lpop l $zero] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list 2 [irange 3 997] 1 1 2] + +test listrep-4.8 { + Deletes from end of shared spanned list do not create a new allocation + - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.8.1 { + Deletes from end of shared spanned list do not create a new allocation + - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lremove $spanl $end-1 $end] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.8.2 { + Deletes from end of shared spanned list do not create a new allocation + - lrange version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lrange $spanl 0 $end-2] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [irange 2 995] 1 1 3 3] + +test listrep-4.8.3 { + Deletes from end of shared spanned list do not create a new allocation + - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set e [lpop l] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list 997 [irange 2 996] 1 1 2] + +test listrep-4.9 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set i 500 + set l [lreplace $spanl $i $i] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1] + +test listrep-4.9.1 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back - lremove version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set i 500 + set l [lremove $spanl $i $i] + validate $l + list $spanl $l [sameStore $spanl $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 501] [irange 503 997]] 0 1 1 2 1] + +test listrep-4.9.2 { + Deletes from middle of shared spanned list creates a new allocation with + equal free space at front and back - lpop version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + set i 500 + set e [lpop l $i] + validate $l + list $e $l [sameStore $master $l] [hasSpan $l] [spaceEqual $l] [repStoreRefCount $l] +} -result [list 502 [concat [irange 2 501] [irange 503 997]] 0 1 1 1] + +test listrep-4.10 { + Replacements with same number of elements at front of shared spanned list + create a new allocation with more space in front - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-2 -1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.10.1 { + Replacements with same number of elements at front of shared spanned list + create a new allocation with exact size +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $zero -1 + validate $l + list $l [sameStore $master $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [concat {-1} [irange 3 997]] 0 0 1] + +test listrep-4.11 { + Replacements with fewer elements at front of shared spanned list + create a new allocation with more space in front +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.12 { + Replacements with more elements at front of shared spanned list + create a new allocation with more space in front +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $zero $one -3 -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [leadSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {-3 -2 -1} [irange 4 997]] 0 1 1 2 1] + +test listrep-4.13 { + Replacements with same number of elements at back of shared spanned list + create a new allocation with more space in back - lreplace version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000 1001] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001}] 0 1 1 2 1] + +test listrep-4.13.1 { + Replacements with same number of elements at back of shared spanned list + create a new exact allocation with no span - lset version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $end 1000 + validate $l + list $l [sameStore $master $l] [tailSpace $l] [hasSpan $l] [repStoreRefCount $l] +} -result [list [concat [irange 2 996] {1000}] 0 0 0 1] + +test listrep-4.14 { + Replacements with fewer elements at back of shared spanned list + create a new allocation with more space in back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000}] 0 1 1 2 1] + +test listrep-4.15 { + Replacements with more elements at back of shared spanned list + create a new allocation with more space in back +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-1 $end 1000 1001 1002] + validate $l + list $spanl $l [sameStore $spanl $l] [tailSpaceMore $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 995] {1000 1001 1002}] 0 1 1 2 1] + +test listrep-4.16 { + Replacements with same number of elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $one $two -2 -1] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat {2 -2 -1} [irange 5 997]] 0 1 1 2 1] + +test listrep-4.16.1 { + Replacements with same number of elements in middle of shared spanned list + create a new exact allocation - lset version +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set l [lrange $master $two $end-2] + lset l $one -2 + validate $l + list $l [sameStore $master $l] [hasSpan $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [concat {2 -2} [irange 4 997]] 0 0 0 1] + +test listrep-4.17 { + Replacements with fewer elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-2 $end-1 1000] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 994] {1000 997}] 0 1 1 2 1] + +test listrep-4.18 { + Replacements with more elements in middle of shared spanned list + create a new allocation with equal lead and tail sapce +} -constraints testlistrep -body { + set master [freeSpaceNone 1000] + set spanl [lrange $master $two $end-2] + set l [lreplace $spanl $end-2 $end-1 1000 1001 1002] + validate $l + list $spanl $l [sameStore $spanl $l] [spaceEqual $l] [hasSpan $l] [repStoreRefCount $spanl] [repStoreRefCount $l] +} -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] + +# 5.* - tests on shared Tcl_Obj +# Tests when Tcl_Obj is shared but listrep is not. This is to ensure that +# checks for shared values check the Tcl_Obj reference counts in addition to +# the list internal representation reference counts. Probably some or all +# cases are already covered elsewhere but easier to just test than look. +test listrep-5.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lappend l 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] + +test listrep-5.1.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] + +test listrep-5.1.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] +} -result [list 1 [irange 0 6] [irange 0 7] 0 0] + +test listrep-5.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lappend l 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 998] [irange 0 999] 1 1 0] + +# +# 6.* - tests when lists contain zombies. +# The list implementation does lazy freeing in some cases so the list store +# contain Tcl_Obj's that are not actually referenced by any list (zombies). +# These are to be freed next time the list store is modified by a list +# operation as long as it is no longer shared. +test listrep-6.1 { + Verify that zombies are freed up - linsert at front +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $zero -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -1 {*}[irange 10 209]] 1 9 10 1] + +test listrep-6.1.1 { + Verify that zombies are freed up - linsert in middle +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $one -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list 10 -1 {*}[irange 11 209]] 1 9 10 1] + +test listrep-6.1.2 { + Verify that zombies are freed up - linsert at end +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [linsert $l[set l {}] $end 210] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + +test listrep-6.2 { + Verify that zombies are freed up - lrange version (whole) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lrange $l[set l {}] $zero $end] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 209] 1 10 10 1] + +test listrep-6.2.1 { + Verify that zombies are freed up - lrange version (subrange) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lrange $l[set l {}] $one $end-1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 11 208] 1 11 11 1] + +test listrep-6.3 { + Verify that zombies are freed up - lassign version +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lassign $l[set l {}] e] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 10 [irange 11 209] 1 11 10 1] + +test listrep-6.4 { + Verify that zombies are freed up - lremove version (front) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lremove $l[set l {}] $zero] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 11 209] 1 11 10 1] + +test listrep-6.4.1 { + Verify that zombies are freed up - lremove version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lremove $l[set l {}] $end] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 208] 1 10 11 1] + +test listrep-6.5 { + Verify that zombies are freed up - lreplace at front +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lreplace $l[set l {}] $zero $one -3 -2 -1] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -3 -2 -1 {*}[irange 12 209]] 1 9 10 1] + +test listrep-6.5.1 { + Verify that zombies are freed up - lreplace at back +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + # set l {} is for reference counts to drop to 1 + set l [lreplace $l[set l {}] $end-1 $end -1 -2 -3] + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list {*}[irange 10 207] -1 -2 -3] 1 10 9 1] + +test listrep-6.6 { + Verify that zombies are freed up - lappend +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lappend l 210 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + +test listrep-6.7 { + Verify that zombies are freed up - lpop version (front) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + set e [lpop l $zero] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 10 [irange 11 209] 1 11 10 1] + +test listrep-6.7.1 { + Verify that zombies are freed up - lpop version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + set e [lpop l] + list $e $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list 209 [irange 10 208] 1 10 11 1] + +test listrep-6.8 { + Verify that zombies are freed up - lset version +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lset l $zero -1 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [list -1 {*}[irange 11 209]] 1 10 10 1] + +test listrep-6.8.1 { + Verify that zombies are freed up - lset version (back) +} -constraints testlistrep -body { + set l [zombieSample 200 10 10] + set addr [storeAddress $l] + lset l $end+1 210 + list $l [expr {$addr == [storeAddress $l]}] [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] +} -result [list [irange 10 210] 1 10 9 1] + + +# All done +::tcltest::cleanupTests + +return diff --git a/tests/llength.test b/tests/llength.test index a2770c0..1122341 100644 --- a/tests/llength.test +++ b/tests/llength.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. diff --git a/tests/lmap.test b/tests/lmap.test index d986ee2..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. diff --git a/tests/load.test b/tests/load.test index 78087bc..005c451 100644 --- a/tests/load.test +++ b/tests/load.test @@ -4,8 +4,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) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::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,9 +36,9 @@ 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 @@ -47,28 +47,28 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} -returnCodes error -body { load -} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +} -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 ?packageName? ?interp?"} +} -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 package name} +} -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 package name} +} -result {must specify either file name or prefix} test load-1.6 {basic errors} -returnCodes error -body { load {} Unknown -} -result {package "Unknown" isn't loaded statically} +} -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 package name for -global} +} -result {couldn't figure out prefix for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { @@ -84,17 +84,17 @@ test load-2.2 {loading into a safe interpreter, with package name conversion} \ } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] Foo} msg] $msg $errorCode + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode } -match glob \ -result [list 1 {cannot find symbol "Foo_Init"*} \ {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] { - list [catch {load [file join $testDir pkge$ext] Pkge} msg] \ + list [catch {load [file join $testDir pkge$ext] pkge} msg] \ $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing @@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar - set result [list [catch {load [file join $testDir pkge$ext] Pkge x} msg] \ + set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ $msg $::errorInfo $::errorCode] interp delete x set result @@ -119,16 +119,16 @@ test load-3.2 {error in _Init procedure, child interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] Pkga} msg] $msg + 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} } -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\"" +} -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} -setup { catch {interp delete x} @@ -150,78 +150,78 @@ 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 +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] +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] -testConstraint teststaticpkg_8.x 0 -if {[testConstraint teststaticpkg]} { +testConstraint teststaticlibrary_8.x 0 +if {[testConstraint teststaticlibrary]} { catch { - teststaticpkg Test 1 1 - teststaticpkg Another 0 1 - teststaticpkg More 0 1 - teststaticpkg Double 0 1 - testConstraint teststaticpkg_8.x 1 + 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 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +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] { +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} -setup { +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 {teststaticpkg} -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } +} -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 { diff --git a/tests/lpop.test b/tests/lpop.test new file mode 100644 index 0000000..272c82f --- /dev/null +++ b/tests/lpop.test @@ -0,0 +1,145 @@ +# Commands covered: lpop +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +unset -nocomplain no; # following tests expecting var "no" does not exists +test lpop-1.1 {error conditions} -returnCodes error -body { + lpop no +} -result {can't read "no": no such variable} +test lpop-1.2 {error conditions} -returnCodes error -body { + lpop no 0 +} -result {can't read "no": no such variable} +test lpop-1.3 {error conditions} -returnCodes error -body { + set l "x {}x" + lpop l +} -result {list element in braces followed by "x" instead of space} +test lpop-1.4 {error conditions} -returnCodes error -body { + set l "x y" + lpop l -1 +} -result {index "-1" out of range} +test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { + set l "x y" + list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l +} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}} +test lpop-1.5 {error conditions} -returnCodes error -body { + set l "x y z" + lpop l 3 +} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} +test lpop-1.6 {error conditions} -returnCodes error -body { + set l "x y" + lpop l end+1 +} -result {index "end+1" out of range} +test lpop-1.7 {error conditions} -returnCodes error -body { + set l "x y" + lpop l {} +} -match glob -result {bad index *} +test lpop-1.8 {error conditions} -returnCodes error -body { + set l "x y" + lpop l 0 0 0 0 1 +} -result {index "1" out of range} +test lpop-1.9 {error conditions} -returnCodes error -body { + set l "x y" + lpop l {1 0} +} -match glob -result {bad index *} + +test lpop-2.1 {basic functionality} -body { + set l "x y z" + list [lpop l 0] $l +} -result {x {y z}} +test lpop-2.2 {basic functionality} -body { + set l "x y z" + list [lpop l 1] $l +} -result {y {x z}} +test lpop-2.3 {basic functionality} -body { + set l "x y z" + list [lpop l] $l +} -result {z {x y}} +test lpop-2.4 {basic functionality} -body { + set l "x y z" + set l2 $l + list [lpop l] $l $l2 +} -result {z {x y} {x y z}} + +test lpop-3.1 {nested} -body { + set l "x y" + set l2 $l + list [lpop l 0 0 0 0] $l $l2 +} -result {x {{{{}}} y} {x y}} +test lpop-3.2 {nested} -body { + set l "{x y} {a b}" + list [lpop l 0 1] $l +} -result {y {x {a b}}} +test lpop-3.3 {nested} -body { + set l "{x y} {a b}" + list [lpop l 1 0] $l +} -result {a {{x y} b}} + + + + + +test lpop-99.1 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + # Deleting from end should have linear performance + expr {$ratio > 4 ? $ratio : 4} +} -result {4} + +test lpop-99.2 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + expr {$ratio > 10 ? $ratio : 10} +} -result {10} + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lrange.test b/tests/lrange.test index 6765038..695c370 100644 --- a/tests/lrange.test +++ b/tests/lrange.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. @@ -17,10 +17,9 @@ if {"::tcltest" ni [namespace children]} { } ::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]] - test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 @@ -96,16 +95,15 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} { lrange $l 0 end-5 }} {1 2 3 4 5} } {} - test lrange-3.2 {compiled with static indices out of range, negative} { list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] } [lrepeat 4 {}] test lrange-3.3 {compiled with calculated indices out of range, negative constant} { list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] } [lrepeat 4 {}] -test lrange-3.4 {compiled with calculated indices out of range, after end} { +test lrange-3.4 {compiled with calculated indices out of range, after end} -body { list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] -} [lrepeat 4 {}] +} -result [lrepeat 4 {}] test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] @@ -118,22 +116,22 @@ test lrange-3.7a {compiled on empty not canonical list (with static and dynamic list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \ [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1] } [lrepeat 6 {}] -test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} { +test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body { set cmd lrange list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \ [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1] -} [lrepeat 6 {}] +} -result [lrepeat 6 {}] # following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep # (as before the fix [58c46e74b931d3a1]): test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \ [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1] } [lrepeat 6 {}] -test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { +test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body { set cmd lrange list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] -} [lrepeat 6 {}] +} -result [lrepeat 6 {}] test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { testpurebytesobj } -body { @@ -148,6 +146,107 @@ test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] } -result [lrepeat 6 {}] +test lrange-4.1 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object + set x [lrange $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.2 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object, not compiled + set x [[string cat l range] $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.3 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared + set ll2 [lrange $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +test lrange-4.4 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared, not compiled + set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. +# Far too many variations to check with spelt-out tests. +# Note that this *just* checks whether the different versions are the same +# not whether any of them is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lrange lrange + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + # Shared, uncompiled + set ls2 $ls + set expected [list [catch {$lrange $ls $a $b} m] $m] + # Shared, compiled + set tester [list lrange $ls $a $b] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.[incr n].1 {lrange shared compiled} -body \ + [list apply [list {} $script]] -result $expected + # Unshared, uncompiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + [string cat l range] [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.2 {lrange unshared uncompiled} -body \ + [list apply [list {} $script]] -result $expected + # Unshared, compiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + lrange [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.3 {lrange unshared compiled} -body \ + [list apply [list {} $script]] -result $expected + } + } + } +}} # cleanup ::tcltest::cleanupTests diff --git a/tests/lrepeat.test b/tests/lrepeat.test index f62f35f..c1c8b02 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -4,7 +4,7 @@ # 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. diff --git a/tests/lreplace.test b/tests/lreplace.test index b7caf47..55b3ee3 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.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. @@ -111,27 +111,27 @@ test lreplace-1.30 {lreplace command} -body { lreplace {not {}alist} 0 0 [error foo] } -returnCodes 1 -result {foo} -test lreplace-2.1 {lreplace errors} { +test lreplace-2.1 {lreplace errors} -body { list [catch lreplace msg] $msg -} {1 {wrong # args: should be "lreplace list first last ?element ...?"}} -test lreplace-2.2 {lreplace errors} { +} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}} +test lreplace-2.2 {lreplace errors} -body { list [catch {lreplace a b} msg] $msg -} {1 {wrong # args: should be "lreplace list first last ?element ...?"}} -test lreplace-2.3 {lreplace errors} { +} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}} +test lreplace-2.3 {lreplace errors} -body { list [catch {lreplace x a 10} msg] $msg -} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.4 {lreplace errors} { +} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.4 {lreplace errors} -body { list [catch {lreplace x 10 x} msg] $msg -} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.5 {lreplace errors} { +} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.5 {lreplace errors} -body { list [catch {lreplace x 10 1x} msg] $msg -} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.6 {lreplace errors} { +} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.6 {lreplace errors} -body { list [catch {lreplace x 3 2} msg] $msg -} {0 x} -test lreplace-2.7 {lreplace errors} { +} -result {0 x} +test lreplace-2.7 {lreplace errors} -body { list [catch {lreplace x 2 2} msg] $msg -} {0 x} +} -result {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { @@ -228,8 +228,312 @@ apply {{} { set tester [list lreplace $ls $a $b {*}$i] set script [list catch $tester m] set script "list \[$script\] \$m" - test lreplace-6.[incr n] {lreplace battery} \ - [list apply [list {} $script]] $expected + test lreplace-6.[incr n] {lreplace battery} -body \ + [list apply [list {} $script]] -result $expected + } + } + } + } +}} + +# Essentially same tests as above but for ledit +test ledit-1.1 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 0 a] $l +} {{a 2 3 4 5} {a 2 3 4 5}} +test ledit-1.2 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 1 1 a] $l +} {{1 a 3 4 5} {1 a 3 4 5}} +test ledit-1.3 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 2 a] $l +} {{1 2 a 4 5} {1 2 a 4 5}} +test ledit-1.4 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 3 3 a] $l +} {{1 2 3 a 5} {1 2 3 a 5}} +test ledit-1.5 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.6 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 4 5 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.7 {ledit command} { + set l {1 2 3 4 5} + list [ledit l -1 -1 a] $l +} {{a 1 2 3 4 5} {a 1 2 3 4 5}} +test ledit-1.8 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 end a b c d] $l +} {{1 2 a b c d} {1 2 a b c d}} +test ledit-1.9 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 3] $l +} {5 5} +test ledit-1.10 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 4] $l +} {{} {}} +test ledit-1.11 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 0 1] $l +} {{3 4 5} {3 4 5}} +test ledit-1.12 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 2 3] $l +} {{1 2 5} {1 2 5}} +test ledit-1.13 {ledit command} { + set l {1 2 3 4 5} + list [ledit l 3 end] $l +} {{1 2 3} {1 2 3}} +test ledit-1.14 {ledit command} { + set l {1 2 3 4 5} + list [ledit l -1 4 a b c] $l +} {{a b c} {a b c}} +test ledit-1.15 {ledit command} { + set l {a b "c c" d e f} + list [ledit l 3 3] $l +} {{a b {c c} e f} {a b {c c} e f}} +test ledit-1.16 {ledit command} { + set l { 1 2 3 4 5} + list [ledit l 0 0 a] $l +} {{a 2 3 4 5} {a 2 3 4 5}} +test ledit-1.17 {ledit command} { + set l {1 2 3 4 "5 6"} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.18 {ledit command} { + set l {1 2 3 4 {5 6}} + list [ledit l 4 4 a] $l +} {{1 2 3 4 a} {1 2 3 4 a}} +test ledit-1.19 {ledit command} { + set l {1 2 3 4} + list [ledit l 2 end x y z] $l +} {{1 2 x y z} {1 2 x y z}} +test ledit-1.20 {ledit command} { + set l {1 2 3 4} + list [ledit l end end a] $l +} {{1 2 3 a} {1 2 3 a}} +test ledit-1.21 {ledit command} { + set l {1 2 3 4} + list [ledit l end 3 a] $l +} {{1 2 3 a} {1 2 3 a}} +test ledit-1.22 {ledit command} { + set l {1 2 3 4} + list [ledit l end end] $l +} {{1 2 3} {1 2 3}} +test ledit-1.23 {ledit command} { + set l {1 2 3 4} + list [ledit l 2 -1 xy] $l +} {{1 2 xy 3 4} {1 2 xy 3 4}} +test ledit-1.24 {ledit command} { + set l {1 2 3 4} + list [ledit l end -1 z] $l +} {{1 2 3 z 4} {1 2 3 z 4}} +test ledit-1.25 {ledit command} { + set l {\}\ hello} + concat \"[ledit l end end]\" $l +} {"\}\ " \}\ } +test ledit-1.26 {ledit command} { + catch {unset foo} + set foo {a b} + list [ledit foo end end] $foo \ + [ledit foo end end] $foo \ + [ledit foo end end] $foo +} {a a {} {} {} {}} +test ledit-1.27 {lsubset command} -body { + set l x + list [ledit l 1 1] $l +} -result {x x} +test ledit-1.28 {ledit command} -body { + set l x + list [ledit l 1 1 y] $l +} -result {{x y} {x y}} +test ledit-1.29 {ledit command} -body { + set l x + ledit l 1 1 [error foo] +} -returnCodes 1 -result {foo} +test ledit-1.30 {ledit command} -body { + set l {not {}alist} + ledit l 0 0 [error foo] +} -returnCodes 1 -result {foo} +test ledit-1.31 {ledit command} -body { + unset -nocomplain arr + set arr(x) {a b} + list [ledit arr(x) 0 0 c] $arr(x) +} -result {{c b} {c b}} + +test ledit-2.1 {ledit errors} -body { + list [catch ledit msg] $msg +} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}} +test ledit-2.2 {ledit errors} -body { + unset -nocomplain x + list [catch {ledit l b} msg] $msg +} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}} +test ledit-2.3 {ledit errors} -body { + set x {} + list [catch {ledit x a 10} msg] $msg +} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.4 {ledit errors} -body { + set l {} + list [catch {ledit l 10 x} msg] $msg +} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.5 {ledit errors} -body { + set l {} + list [catch {ledit l 10 1x} msg] $msg +} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} +test ledit-2.6 {ledit errors} -body { + set l x + list [catch {ledit l 3 2} msg] $msg +} -result {0 x} +test ledit-2.7 {ledit errors} -body { + set l x + list [catch {ledit l 2 2} msg] $msg +} -result {0 x} +test ledit-2.8 {ledit errors} -body { + unset -nocomplain l + ledit l 0 0 x +} -returnCodes error -result {can't read "l": no such variable} +test ledit-2.9 {ledit errors} -body { + unset -nocomplain arr + ledit arr(x) 0 0 x +} -returnCodes error -result {can't read "arr(x)": no such variable} +test ledit-2.10 {ledit errors} -body { + unset -nocomplain arr + set arr(y) y + ledit arr(x) 0 0 x +} -returnCodes error -result {can't read "arr(x)": no such element in array} + +test ledit-3.1 {ledit won't modify shared argument objects} { + proc p {} { + set l "a b c" + ledit l 1 1 "x y" + # The literal in locals table should be unmodified + return [list "a b c" $l] + } + p +} {{a b c} {a {x y} c}} + +# Following bugs were in lreplace. Make sure ledit does not have them +test ledit-4.1 {Bug ccc2c2cc98: lreplace edge case} { + set l {} + list [ledit l 1 1] $l +} {{} {}} +test ledit-4.2 {Bug ccc2c2cc98: lreplace edge case} { + set l { } + list [ledit l 1 1] $l +} {{} {}} +test ledit-4.3 {lreplace edge case} { + set l {1 2 3} + ledit l 2 0 +} {1 2 3} +test ledit-4.4 {ledit edge case} { + set l {1 2 3 4 5} + list [ledit l 3 1] $l +} {{1 2 3 4 5} {1 2 3 4 5}} +test ledit-4.5 {ledit edge case} { + lreplace {1 2 3 4 5} 3 0 _ +} {1 2 3 _ 4 5} +test ledit-4.6 {ledit end-x: bug a4cb3f06c4} { + set l {0 1 2 3 4} + list [ledit l 0 end-2] $l +} {{3 4} {3 4}} +test ledit-4.6.1 {ledit end-x: bug a4cb3f06c4} { + set l {0 1 2 3 4} + list [ledit l 0 end-2 a b c] $l +} {{a b c 3 4} {a b c 3 4}} +test ledit-4.7 {ledit with two end-indexes: increasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-1] $l +} {{0 1 4} {0 1 4}} +test ledit-4.7.1 {ledit with two end-indexes: increasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-1 a b c] $l +} {{0 1 a b c 4} {0 1 a b c 4}} +test ledit-4.8 {ledit with two end-indexes: equal} { + set l {0 1 2 3 4} + list [ledit l end-2 end-2] $l +} {{0 1 3 4} {0 1 3 4}} +test ledit-4.8.1 {ledit with two end-indexes: equal} { + set l {0 1 2 3 4} + list [ledit l end-2 end-2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.9 {ledit with two end-indexes: decreasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-3] $l +} {{0 1 2 3 4} {0 1 2 3 4}} +test ledit-4.9.1 {ledit with two end-indexes: decreasing} { + set l {0 1 2 3 4} + list [ledit l end-2 end-3 a b c] $l +} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}} +test ledit-4.10 {ledit with two equal indexes} { + set l {0 1 2 3 4} + list [ledit l 2 2] $l +} {{0 1 3 4} {0 1 3 4}} +test ledit-4.10.1 {ledit with two equal indexes} { + set l {0 1 2 3 4} + list [ledit l 2 2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.11 {ledit end index first} { + set l {0 1 2 3 4} + list [ledit l end-2 1 a b c] $l +} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}} +test ledit-4.12 {ledit end index first} { + set l {0 1 2 3 4} + list [ledit l end-2 2 a b c] $l +} {{0 1 a b c 3 4} {0 1 a b c 3 4}} +test ledit-4.13 {ledit empty list} { + set l {} + list [ledit l 1 1 1] $l +} {1 1} +test ledit-4.14 {ledit empty list} { + set l {} + list [ledit l 2 2 2] $l +} {2 2} + +test ledit-5.1 {compiled lreplace: Bug 47ac84309b} { + apply {x { + ledit x end 0 + }} {a b c} +} {a b c} +test ledit-5.2 {compiled lreplace: Bug 47ac84309b} { + apply {x { + ledit x end 0 A + }} {a b c} +} {a b A c} + +test ledit-bug-a366c6efee {Bug [a366c6efee]} -body { + apply {{} { + set l { } + string length [ledit l 1 1]; # Force string generation + set result foo + append result " " bar + }} +} -result "foo bar" + +# Testing for compiled behaviour. Far too many variations to check with +# spelt-out tests. Note that this *just* checks whether the compiled version +# and the interpreted version are the same, not whether the interpreted +# version is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set ins {{} A {A B}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lreplace lreplace + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + foreach i $ins { + set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] + set tester [list ledit ls $a $b {*}$i] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test ledit-6.[incr n] {ledit battery} -body \ + [list apply [list {ls} $script] $ls] -result $expected } } } diff --git a/tests/lsearch.test b/tests/lsearch.test index 27ae4aa..c913e60 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.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-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. @@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} { } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x -} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body { } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.4 {lsearch errors} -returnCodes error -body { lsearch a b c d -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.5 {lsearch errors} -returnCodes error -body { lsearch "\{" b } -result {unmatched open brace in list} @@ -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 @@ -432,19 +432,19 @@ test lsearch-17.11 {lsearch -index option, empty argument} { } [lsearch [list \{] \{] test lsearch-17.12 {lsearch -index option, encoding aliasing} -body { lsearch -index -2 a a -} -returnCodes error -result {index "-2" cannot select an element from any list} +} -returnCodes error -result {index "-2" out of range} test lsearch-17.13 {lsearch -index option, encoding aliasing} -body { lsearch -index -1-1 a a -} -returnCodes error -result {index "-1-1" cannot select an element from any list} +} -returnCodes error -result {index "-1-1" out of range} test lsearch-17.14 {lsearch -index option, encoding aliasing} -body { lsearch -index end--1 a a -} -returnCodes error -result {index "end--1" cannot select an element from any list} +} -returnCodes error -result {index "end--1" out of range} test lsearch-17.15 {lsearch -index option, encoding aliasing} -body { lsearch -index end+1 a a -} -returnCodes error -result {index "end+1" cannot select an element from any list} +} -returnCodes error -result {index "end+1" out of range} test lsearch-17.16 {lsearch -index option, encoding aliasing} -body { lsearch -index end+2 a a -} -returnCodes error -result {index "end+2" cannot select an element from any list} +} -returnCodes error -result {index "end+2" out of range} test lsearch-18.1 {lsearch -index option, list as index basic functionality} { @@ -478,6 +478,9 @@ test lsearch-19.4 {lsearch -subindices option} { test lsearch-19.5 {lsearch -subindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} +test lsearch-19.6 {lsearch -subindices option} { + lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {{0 1 0} {1 1 0}} test lsearch-19.7 {lsearch -subindices option} { lsearch -subindices -index end {{1 a}} a } {0 1} @@ -543,6 +546,152 @@ test lsearch-22.5 {lsearch -bisect, all equal} { test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} + +test lsearch-23.1 {lsearch -stride option, errors} -body { + lsearch -stride {a b} a +} -returnCodes error -result {"-stride" option must be followed by stride length} +test lsearch-23.2 {lsearch -stride option, errors} -body { + lsearch -stride 0 {a b} a +} -returnCodes error -match glob -result {stride length must be between 1 and *} +test lsearch-23.3 {lsearch -stride option, errors} -body { + lsearch -stride 2 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.4 {lsearch -stride option, errors} -body { + lsearch -stride 5 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.5 {lsearch -stride option, errors} -body { + # Stride equal to length is ok + lsearch -stride 3 {a b c} a +} -result 0 + +test lsearch-24.1 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} d +} -result -1 +test lsearch-24.2 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} e +} -result 4 +test lsearch-24.3 {lsearch -stride option} -body { + lsearch -stride 3 {a b c d e f g h i} e +} -result -1 +test lsearch-24.4 {lsearch -stride option} -body { + # Result points first in group + lsearch -stride 3 -index 1 {a b c d e f g h i} e +} -result 3 +test lsearch-24.5 {lsearch -stride option} -body { + lsearch -inline -stride 2 {a b c d e f g h} d +} -result {} +test lsearch-24.6 {lsearch -stride option} -body { + # Inline result is a "single element" strided list + lsearch -inline -stride 2 {a b c d e f g h} e +} -result "e f" +test lsearch-24.7 {lsearch -stride option} -body { + lsearch -inline -stride 3 {a b c d e f g h i} e +} -result {} +test lsearch-24.8 {lsearch -stride option} -body { + lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e +} -result "d e f" +test lsearch-24.9 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e +} -result "d e f g e i" +test lsearch-24.10 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a +} -result "a b c a e i" +test lsearch-24.11 {lsearch -stride option} -body { + # Stride 1 is same as no stride + lsearch -stride 1 {a b c d e f g h} d +} -result 3 + +# 25* mimics 19* but with -inline added to -subindices +test lsearch-25.1 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.2 {lsearch -subindices option} { + lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.3 {lsearch -subindices option} { + lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +} {bb} +test lsearch-25.4 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} +} {cb} +test lsearch-25.5 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} +test lsearch-25.6 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} + +# 26* mimics 19* but with -stride added +test lsearch-26.1 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {3 0} +test lsearch-26.2 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {2 0} +test lsearch-26.3 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {1 1} +test lsearch-26.4 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {0 1} +test lsearch-26.5 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {{0 0} {3 0}} +test lsearch-26.6 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {{1 0} {4 0}} + +# 27* mimics 25* but with -stride added +test lsearch-27.1 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.2 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.3 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {bb} +test lsearch-27.4 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {cb} +test lsearch-27.5 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {a a} +test lsearch-27.6 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {a a} + +test lsearch-28.1 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 5 +} -result 0 +test lsearch-28.2 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 3 +} -result -1 +test lsearch-28.3 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 7 +} -result 2 +test lsearch-28.4 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 8 +} -result -1 +test lsearch-28.5 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.6 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 2 +} -result -1 +test lsearch-28.7 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.8 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9 +} -result 5 +test lsearch-28.9 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9 +} -result 9 +test lsearch-28.10 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 4294967296 -index 1 -subindices -inline {3 5 8 7 2 9} 9 +} -returnCodes 1 -match glob -result {stride length must be between 1 and *} + # cleanup catch {unset res} diff --git a/tests/lseq.test b/tests/lseq.test new file mode 100644 index 0000000..4c1f14b --- /dev/null +++ b/tests/lseq.test @@ -0,0 +1,702 @@ +# Commands covered: lseq +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 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 {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +testConstraint arithSeriesDouble 1 +testConstraint arithSeriesShimmer 1 +testConstraint arithSeriesShimmerOk 1 +#testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] +#testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] + +proc memusage {} { + set fd [open /proc/[pid]/statm] + set line [gets $fd] + if {[llength $line] != 7} { + error "Unexpected /proc/pid/statm format" + } + return [lindex $line 5] +} +testConstraint hasMemUsage [expr {![catch {memusage}]}] + +# Arg errors +test lseq-1.1 {error cases} -body { + lseq +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + + +test lseq-1.2 {step magnitude} { + lseq 10 .. 1 by -2 ;# or this could be an error - or not +} {10 8 6 4 2} + +test lseq-1.3 {synergy between int and double} -body { + set rl [lseq 25. to 5. by -5] + set il [lseq 25 to 5 by -5] + lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } +} -cleanup { + unset rl il +} -result {1 1 1 1 1} + +test lseq-1.4 {integer decreasing} { + lseq 10 .. 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-1.5 {integer increasing} { + lseq 1 .. 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-1.6 {integer decreasing with step} { + lseq 10 .. 1 by -2 +} {10 8 6 4 2} + +test lseq-1.7 {real increasing lseq} arithSeriesDouble { + lseq 5.0 to 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} + +test lseq-1.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 to 25. by 5 +} {5.0 10.0 15.0 20.0 25.0} + +test lseq-1.9 {real decreasing with step} arithSeriesDouble { + lseq 25. to 5. by -5 +} {25.0 20.0 15.0 10.0 5.0} + +# note, 10 cannot be in such a list, but allowed +test lseq-1.10 {integer lseq with step} { + lseq 1 to 10 by 2 +} {1 3 5 7 9} + +test lseq-1.11 {error case: increasing wrong step direction} { + lseq 1 to 10 by -2 +} {} + +test lseq-1.12 {decreasing lseq with step} arithSeriesDouble { + lseq 25. to -25. by -5 +} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} + +test lseq-1.13 {count operation} { + -body { + lseq 5 count 5 + } + -result {5 6 7 8 9} +} + +test lseq-1.14 {count with step} { + -body { + lseq 5 count 5 by 2 + } + -result {5 7 9 11 13} +} + +test lseq-1.15 {count with decreasing step} { + -body { + lseq 5 count 5 by -2 + } + -result {5 3 1 -1 -3} +} + +test lseq-1.16 {large numbers} { + -body { + lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] + } + -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} +} + +test lseq-1.17 {too many arguments} -body { + lseq 12 to 24 by 2 with feeling +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.18 {too many arguments extra valid keyword} -body { + lseq 12 to 24 by 2 count +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.19 {too many arguments extra numeric value} -body { + lseq 12 to 24 by 2 7 +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.20 {bug: wrong length computed} { + lseq 1 to 10 -1 +} {} + +test lseq-1.21 {n n by n} { + lseq 66 84 by 3 +} {66 69 72 75 78 81 84} + +test lseq-1.22 {n n by -n} { + lseq 84 66 by -3 +} {84 81 78 75 72 69 66} + +# +# Short-hand use cases +# +test lseq-2.2 {step magnitude} { + lseq 10 1 2 ;# this is an empty case since step has wrong sign +} {} + +test lseq-2.3 {step wrong sign} arithSeriesDouble { + lseq 25. 5. 5 ;# ditto - empty list +} {} + +test lseq-2.4 {integer decreasing} { + lseq 10 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-2.5 {integer increasing} { + lseq 1 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-2.6 {integer decreasing with step} { + lseq 10 1 by -2 +} {10 8 6 4 2} + +test lseq-2.7 {real increasing lseq} arithSeriesDouble { + lseq 5.0 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} + + +test lseq-2.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 25. 5 +} {5.0 10.0 15.0 20.0 25.0} + + +test lseq-2.9 {real decreasing with step} arithSeriesDouble { + lseq 25. 5. -5 +} {25.0 20.0 15.0 10.0 5.0} + +test lseq-2.10 {integer lseq with step} { + lseq 1 10 2 +} {1 3 5 7 9} + +test lseq-2.11 {error case: increasing wrong step direction} { + lseq 1 10 -2 +} {} + +test lseq-2.12 {decreasing lseq with step} arithSeriesDouble { + lseq 25. -25. -5 +} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} + +test lseq-2.13 {count only operation} { + lseq 5 +} {0 1 2 3 4} + +test lseq-2.14 {count with step} { + lseq 5 count 5 2 +} {5 7 9 11 13} + +test lseq-2.15 {count with decreasing step} { + lseq 5 count 5 -2 +} {5 3 1 -1 -3} + +test lseq-2.16 {large numbers} { + lseq 1e6 2e6 1e5 +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} + +test lseq-2.17 {large numbers} arithSeriesDouble { + lseq 1e6 2e6 1e5 +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} + +# Covered: {10 1 2 } {1 10 2} {1 10 -2} {1 1 1} {1 1 1} {-5 17 3} +# Missing: {- - +} {- - -} {- + -} {+ - -} {- - +} {+ + -} +test lseq-2.18 {signs} { + list [lseq -10 -1 2] \ + [lseq -10 -1 -1] \ + [lseq -10 1 -3] \ + [lseq 10 -1 -4] \ + [lseq -10 -1 3] \ + [lseq 10 1 -5] + +} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}} + +test lseq-3.1 {experiement} -body { + set ans {} + foreach factor [lseq 2.0 10.0] { + set start 1 + set end 10 + for {set step 1} {$step < 1e8} {} { + set l [lseq $start to $end by $step] + if {[llength $l] != 10} { + lappend ans $factor $step [llength $l] $l + } + set step [expr {$step * $factor}] + set end [expr {$end * $factor}] + } + } + if {$ans eq {}} { + set ans OK + } + set ans +} -cleanup { + unset ans step end start factor l +} -result {OK} + +test lseq-3.2 {error case} -body { + lseq foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.3 {error case} -body { + lseq 10 foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.4 {error case} -body { + lseq 25 or 6 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.5 {simple count and step arguments} -body { + set s [lseq 25 by 6] + list $s length=[llength $s] +} -cleanup { + unset s +} -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25} + +test lseq-3.6 {error case} -body { + lseq 1 7 or 3 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.7 {lmap lseq} -body { + lmap x [lseq 5] { expr {$x * $x} } +} -cleanup {unset x} -result {0 1 4 9 16} + +test lseq-3.8 {lrange lseq} -body { + set r [lrange [lseq 1 100] 10 20] + set empty [lrange [lseq 1 100] 20 10] + list $r $empty [lindex [tcl::unsupported::representation $r] 3] +} -cleanup { + unset r empty +} -result {{11 12 13 14 15 16 17 18 19 20 21} {} arithseries} + +test lseq-3.9 {lassign lseq} -constraints arithSeriesShimmer -body { + set r [lseq 15] + set r2 [lassign $r a b] + list [lindex [tcl::unsupported::representation $r] 3] $a $b \ + [lindex [tcl::unsupported::representation $r2] 3] +} -cleanup {unset r r2 a b} -result {arithseries 0 1 arithseries} + +test lseq-3.10 {lsearch lseq must shimmer?} -constraints arithSeriesShimmer -body { + set r [lseq 15 0] + set a [lsearch $r 9] + list [lindex [tcl::unsupported::representation $r] 3] $a +} -cleanup {unset r a} -result {arithseries 6} + +test lseq-3.11 {lreverse lseq} -body { + set r [lseq 15 0] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} -cleanup {unset r a} -result {arithseries +15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 +arithseries +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} + +test lseq-3.12 {in operator} -body { + set r [lseq 9] + set i [expr {7 in $r}] + set j [expr {10 ni $r}] + set k [expr {-1 in $r}] + set l [expr {4 ni $r}] + list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3] +} -cleanup { + unset r i j k l +} -result {1 1 0 0 arithseries} + +test lseq-3.13 {lmap lseq shimmer} -constraints arithSeriesShimmer -body { + set r [lseq 15] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set m [lmap i $r { expr {$i * 7} }] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + set rep-m [lindex [tcl::unsupported::representation $m] 3] + list $r ${rep-before} ${rep-after} ${rep-m} $m +} -cleanup { + unset r rep-before m rep-after rep-m +} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}} + +test lseq-3.14 {array for shimmer} -constraints arithSeriesShimmerOk -body { + array set testarray {a Test for This great Function} + set vars [lseq 2] + set vars-rep [lindex [tcl::unsupported::representation $vars] 3] + array for $vars testarray { + lappend keys $0 + lappend vals $1 + } + # Since hash order is not guaranteed, have to validate content ignoring order + set valk [lmap k $keys {expr {$k in {a for great}}}] + set valv [lmap v $vals {expr {$v in {Test This Function}}}] + set vars-after [lindex [tcl::unsupported::representation $vars] 3] + list ${vars-rep} $valk $valv ${vars-after} +} -cleanup { + unset testarray vars vars-rep 0 valk k valv v vars-after +} -result {arithseries {1 1 1} {1 1 1} arithseries} + +test lseq-3.15 {join for shimmer} -constraints arithSeriesShimmer -body { + set r [lseq 3] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set str [join $r :] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $str ${rep-after} +} -cleanup { + unset r rep-before str rep-after +} -result {arithseries 0:1:2 arithseries} + +test lseq-3.16 {error case} -body { + lseq 16 to +} -returnCodes 1 -result {missing "to" value.} + +test lseq-3.17 {error case} -body { + lseq 17 to 13 by +} -returnCodes 1 -result {missing "by" value.} + +test lseq-3.18 {error case} -body { + lseq 18 count +} -returnCodes 1 -result {missing "count" value.} + +test lseq-3.19 {edge case} -body { + lseq 1 count 5 by 0 +} -result {} +# 1 1 1 1 1 + +# My thought is that this is likely a user error, since they can always use lrepeat for this. + +test lseq-3.20 {edge case} -body { + lseq 1 to 1 by 0 +} -result {} + +# hmmm, I guess this is right, in a way, so... + +test lseq-3.21 {edge case} { + lseq 1 to 1 by 1 +} {1} + +test lseq-3.22 {edge case} { + lseq 1 1 1 +} {1} + +test lseq-3.23 {edge case} { + llength [lseq 1 1 1] +} {1} + +test lseq-3.24 {edge case} { + llength [lseq 1 to 1 1] +} {1} + +test lseq-3.25 {edge case} { + llength [lseq 1 to 1 by 1] +} {1} + +test lseq-3.26 {lsort shimmer} -constraints arithSeriesShimmer -body { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lsort $r] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} -cleanup { + unset r rep-before lexical_sort rep-after +} -result {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries} + +test lseq-3.27 {lreplace shimmer} -constraints arithSeriesShimmer -body { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lreplace $r 3 5 A B C] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} -cleanup { + unset r + unset rep-before + unset lexical_sort + unset rep-after +} -result {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} + +test lseq-3.28 {lreverse bug in ArithSeries} -body { + set r [lseq -5 17 3] + set rr [lreverse $r] + list $r $rr [string equal $r [lreverse $rr]] +} -cleanup { + unset r rr +} -result {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1} + +test lseq-3.29 {edge case: negative count} { + lseq -15 +} {} + +test lseq-3.30 {lreverse with double values} -constraints arithSeriesDouble -body { + set r [lseq 3.5 18.5 1.5] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} -cleanup { + unset r a +} -result {arithseries +3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5 +arithseries +18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5} + +test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble} { + lreverse [lseq 1.1 29.9 0.3] +} {29.9 29.6 29.3 29.0 28.7 28.4 28.1 27.8 27.5 27.2 26.9 26.6 26.3 26.0 25.7 25.4 25.1 24.8 24.5 24.2 23.9 23.6 23.3 23.0 22.7 22.4 22.1 21.8 21.5 21.2 20.9 20.6 20.3 20.0 19.7 19.4 19.1 18.8 18.5 18.2 17.9 17.6 17.3 17.0 16.7 16.4 16.1 15.8 15.5 15.2 14.9 14.6 14.3 14.0 13.7 13.4 13.1 12.8 12.5 12.2 11.9 11.6 11.3 11.0 10.7 10.4 10.1 9.8 9.5 9.2 8.9 8.6 8.3 8.0 7.7 7.4 7.1 6.8 6.5 6.2 5.9 5.6 5.3 5.0 4.7 4.4 4.1 3.8 3.5 3.2 2.9 2.6 2.3 2.0 1.7 1.4 1.1} + +# lsearch - +# -- should not shimmer lseq list +# -- should not leak lseq elements +test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body { + set srchlist {} + for {set i 5} {$i < 25} {incr i} { + lappend srchlist [lseq $i count 7 by 3] + } + set a [lsearch -all -inline -index 1 $srchlist 23] + set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}] + list [lindex [tcl::unsupported::representation $a] 3] $a $b \ + [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] +} -cleanup { + unset srchlist i a b +} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} + +test lseq-4.1 {end expressions} -body { + set start 7 + lseq $start $start+11 +} -cleanup {unset start} -result {7 8 9 10 11 12 13 14 15 16 17 18} + +test lseq-4.2 {start expressions} -body { + set base [clock seconds] + set tl [lseq $base-60 $base 10] + lmap t $tl {expr {$t - $base + 60}} +} -cleanup {unset base tl t} -result {0 10 20 30 40 50 60} + +## lseq 1 to 10 by -2 +## # -> lseq: invalid step = -2 with a = 1 and b = 10 + +test lseq-4.3 {TIP examples} -body { + set examples {# Examples from TIP-629 + # --- Begin --- + lseq 10 .. 1 + # -> 10 9 8 7 6 5 4 3 2 1 + lseq 1 .. 10 + # -> 1 2 3 4 5 6 7 8 9 10 + lseq 10 .. 1 by 2 + # -> + lseq 10 .. 1 by -2 + # -> 10 8 6 4 2 + lseq 5.0 to 15. + # -> 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 + lseq 5.0 to 25. by 5 + # -> 5.0 10.0 15.0 20.0 25.0 + lseq 25. to 5. by 5 + # -> + lseq 25. to 5. by -5 + # -> 25.0 20.0 15.0 10.0 5.0 + lseq 1 to 10 by 2 + # -> 1 3 5 7 9 + lseq 25. to -25. by -5 + # -> 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0 + lseq 5 5 + # -> 5 + lseq 5 5 2 + # -> 5 + lseq 5 5 -2 + # -> 5 + } + set res {} + foreach {cmd expect} [split $examples \n] { + if {[string trim $cmd] ne ""} { + set cmd [string trimleft $cmd] + if {[string match {\#*} $cmd]} continue + set status [catch $cmd ans] + lappend res $ans + if {[regexp {\# -> (.*)$} $expect -> expected]} { + if {$expected ne $ans} { + lappend res [list Mismatch: $cmd -> $ans ne $expected] + } + } + } + } + set res +} -cleanup { + unset res cmd status ans expect expected examples +} -result {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5} + +# +# Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case +test lseq-4.4 {lseq corner case} -body { + set tcmd { + set res {} + set s [catch {lindex [lseq 10 100] 0} e] + lappend res $s $e + set s [catch {lindex [lseq 10 9223372036854775000] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 9223372036854775000]} e] + lappend res $s $e + set s [catch {lindex [lseq 10 2147483647] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 2147483647]} e] + lappend res $s $e + } + eval $tcmd +} -cleanup { + unset res s e tcmd +} -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638} + +# Ticket 99e834bf33 - lseq, lindex end off by one + +test lseq-4.5 {lindex off by one} -body { + lappend res [eval {lindex [lseq 1 4] end}] + lappend res [eval {lindex [lseq 1 4] end-1}] +} -setup { + # Since 4.3 does not clean up and 4.4 may not run under constraint + set res {} +} -cleanup { + unset res +} -result {4 3} + +# Bad refcount on ResultObj +test lseq-4.6 {lindex flat} -body { + set l [lseq 2 10] + set cmd lindex + set i 4 + set c [lindex $l $i] + set d [$cmd $l $i] + set e [lindex [lseq 2 10] $i] + set f [$cmd [lseq 2 10] $i] + list $c $d $e $f +} -cleanup { + unset l cmd i c d e f +} -result [lrepeat 4 6] + +test lseq-4.7 {empty list} { + list [lseq 0] [join [lseq 0] {}] [join [lseq 1] {}] +} {{} {} 0} + +test lseq-4.8 {error case lrange} -body { + lrange [lseq 1 5] fred ginger +} -cleanup { + unset -nocomplain fred ginger +} -returnCodes 1 -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?} + +test lseq-4.9 {lrange empty/partial sets} -body { + set res {} + foreach {fred ginger} {7 8 4 9 0 15 9 9 4 2} { + lappend res [lrange [lseq 1 5] $fred $ginger] + } + set res +} -cleanup {unset res fred ginger} -result {{} 5 {1 2 3 4 5} {} {}} + +# Panic when using variable value? +test lseq-4.10 {panic using variable index} -body { + set i 0 + lindex [lseq 10] $i +} -cleanup {unset i} -result {0} + +test lseq-4.11 {bug lseq / lindex discrepancies} -body { + lindex [lseq 0x7fffffff] 0x80000000 +} -result {} + +test lseq-4.12 {bug lseq} -body { + llength [lseq 0x100000000] +} -returnCodes 1 -result {max length of a Tcl list exceeded} + +test lseq-4.13 {bug lseq} -constraints knownBug -body { + set l [lseq 0x7fffffffffffffff] + list \ + [llength $l] \ + [lindex $l end] \ + [lindex $l 9223372036854775800] +} -cleanup {unset l} -result {9223372036854775807 9223372036854775806 9223372036854775800} + + +test lseq-4.14 {bug lseq - inconsistent rounding} { + # using a non-integer increment, [lseq] rounding seems to be not consistent: + lseq 4 40 0.1 +} {4.0 4.1 4.2 4.3 4.4 4.5 4.6 4.7 4.8 4.9 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.7 5.8 5.9 6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0} + +test lseq-4.15 {bug lseq - inconsistent rounding} { + # using a non-integer increment, [lseq] rounding seems to be not consistent: + lseq 6 40 0.1 +} {6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0} + +test lseq-4.16 {bug lseq - inconsistent rounding} { + # using a non-integer increment, [lseq] rounding seems to be not consistent: + set res {} + lappend res [lseq 4.07 6 0.1] + lappend res [lseq 4.03 4.208 0.013] +} {{4.07 4.17 4.27 4.37 4.47 4.57 4.67 4.77 4.87 4.97 5.07 5.17 5.27 5.37 5.47 5.57 5.67 5.77 5.87 5.97} {4.03 4.043 4.056 4.069 4.082 4.095 4.108 4.121 4.134 4.147 4.16 4.173 4.186 4.199}} + +# Test abstract list in a concat +# -- lseq list should not shimmer +# -- lseq elements should not leak +test lseq-4.17 {concat shimmer} -body { + set rng [lseq 8 15 2] + set pre [list A b C] + set pst [list x Y z] + list [concat $pre $rng $pst] \ + [lindex [tcl::unsupported::representation $pre] 3] \ + [lindex [tcl::unsupported::representation $rng] 3] \ + [lindex [tcl::unsupported::representation $pst] 3] +} -cleanup {unset rng pre pst} -result {{A b C 8 10 12 14 x Y z} list arithseries list} + +test lseq-4.18 {concat shimmer} -body { + set rng [lseq 8 15 2] + set pre [list A b C] + set pst [list x Y z] + list [concat $rng $pre $pst] \ + [lindex [tcl::unsupported::representation $rng] 3] \ + [lindex [tcl::unsupported::representation $pre] 3] \ + [lindex [tcl::unsupported::representation $pst] 3] +} -cleanup {unset rng pre pst} -result {{8 10 12 14 A b C x Y z} arithseries list list} + +# Test lseq elements as var names +test lseq-4.19 {varnames} -body { + set plist {} + foreach v {auto_execok auto_load auto_qualify} { + lappend plist proc $v [info args $v] [info body $v] + } + set res {} + set varlist [lseq 1 to 4] + foreach $varlist $plist { + lappend res $2 [llength $3] + } + lappend res [lindex [tcl::unsupported::representation $varlist] 3] +} -cleanup { + unset {*}$varlist res varlist v plist +} -result {auto_execok 1 auto_load 2 auto_qualify 2 arithseries} + +test lseq-convertToList {does not result in a memory error} -body { + trace add variable var1 write [list ::apply [list args { + error {this is an error} + } [namespace current]]] + list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres +} -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}} + +test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { + hasMemUsage +} -body { + set l [lseq 1000000] + proc p l {foreach x $l {}} + set premem [memusage] + p $l + set postmem [memusage] + expr {($postmem - $premem) < 10} +} -result 1 + +# cleanup +::tcltest::cleanupTests + +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lset.test b/tests/lset.test index 0ce1c6d..72d68ec 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -6,7 +6,7 @@ # 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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] proc failTrace {name1 name2 op} { error "trace failed" @@ -97,31 +97,31 @@ test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex { list [catch { testevalex {lset a [list -1] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list 4] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "4" out of range}} test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end--2] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end+2] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end-3] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end-3" out of range}} test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex { set a "x \{" list [catch { @@ -139,31 +139,31 @@ test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex { list [catch { testevalex {lset a -1 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a 4 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "4" out of range}} test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end--2 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end+2 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end-3 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end-3" out of range}} test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex { list [catch { @@ -281,43 +281,43 @@ test lset-8.4 {lset, not compiled, bad second index} testevalex { test lset-8.5 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 -1 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-8.6 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 -1} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-8.7 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 3 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "3" out of range}} test lset-8.8 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 3} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "3" out of range}} test lset-8.9a {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end--2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-8.9b {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end+2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-8.10a {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end--2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-8.10b {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end+2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-8.11 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end-2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end-2" out of range}} test lset-8.12 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end-2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end-2" out of range}} test lset-9.1 {lset, not compiled, entire variable} testevalex { set a x diff --git a/tests/lsetComp.test b/tests/lsetComp.test index d50e0b2..a719fe4 100644 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -6,7 +6,7 @@ # 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. @@ -219,7 +219,7 @@ test lsetComp-2.8 {lset, compiled, list of args, error } { set x { {1 2} {3 4} } lset x {1 5} 5 } -} "1 {list index out of range}" +} {1 {index "5" out of range}} test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} { set ::x { { 1 2 } { 3 4 } } @@ -412,7 +412,7 @@ test lsetComp-3.8 {lset, compiled, flat args, error } { set x { {1 2} {3 4} } lset x 1 5 5 } -} "1 {list index out of range}" +} {1 {index "5" out of range}} test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} { set ::x { { 1 2 } { 3 4 } } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 0a147f0..5a62a2a 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -4,7 +4,7 @@ # 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. diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index e68c4bb..df35b8d 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -4,8 +4,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) 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. @@ -14,7 +14,6 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } - set oldTSF $::tcltest::testSingleFile set ::tcltest::testSingleFile false diff --git a/tests/main.test b/tests/main.test index 758a7d0..4aadd79 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,8 +1,8 @@ # This file contains a collection of tests for generic/tclMain.c. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { @@ -11,12 +11,10 @@ namespace eval ::tcl::test::main { # Is [exec] defined? testConstraint exec [llength [info commands exec]] - # Is the Tcltest package loaded? - # - that is, the special C-coded testing commands in tclTest.c - # - tests use testing commands introduced in Tcltest 8.4 - testConstraint Tcltest [expr { - [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.4]}] + # Is the tcl::test package loaded? + testConstraint tcl::test [expr { + [llength [package provide tcl::test]] + && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { @@ -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 iso8859-1 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,8 +606,8 @@ 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"] @@ -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 3a46314..3c25a2b 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 {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -95,7 +95,7 @@ proc TestOp {op args} { } return [lindex $results 0] } - + # start of tests namespace eval ::testmathop { @@ -114,22 +114,22 @@ namespace eval ::testmathop { test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.11 {compiled +: errors} -returnCodes error -body { + x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.13 {compiled +: errors} -returnCodes error -body { + 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError @@ -152,22 +152,22 @@ namespace eval ::testmathop { test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.29 {interpreted +: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.31 {interpreted +: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -189,22 +189,22 @@ namespace eval ::testmathop { test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.11 {compiled *: errors} -returnCodes error -body { * x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.13 {compiled *: errors} -returnCodes error -body { * 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError @@ -227,22 +227,22 @@ namespace eval ::testmathop { test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.29 {interpreted *: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.31 {interpreted *: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -261,7 +261,7 @@ namespace eval ::testmathop { test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0 test mathop-3.8 {compiled !: errors} -body { ! foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.9 {compiled !: errors} -body { ! 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -278,7 +278,7 @@ namespace eval ::testmathop { test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0 test mathop-3.18 {interpreted !: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.19 {interpreted !: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -287,10 +287,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.21 {compiled !: error} -returnCodes error -body { ! NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-4.1 {compiled ~} {~ 0} -1 test mathop-4.2 {compiled ~} {~ 1} -2 @@ -301,7 +301,7 @@ namespace eval ::testmathop { test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001 test mathop-4.8 {compiled ~: errors} -body { ~ foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -310,10 +310,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} set op ~ test mathop-4.13 {interpreted ~} {$op 0} -1 test mathop-4.14 {interpreted ~} {$op 1} -2 @@ -324,7 +324,7 @@ namespace eval ::testmathop { test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001 test mathop-4.20 {interpreted ~: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -333,10 +333,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} test mathop-5.1 {compiled eq} {eq {} a} 0 test mathop-5.2 {compiled eq} {eq a a} 1 @@ -377,32 +377,32 @@ namespace eval ::testmathop { test mathop-6.4 {compiled &} { & 3 7 6 } 2 test mathop-6.5 {compiled &} -returnCodes error -body { & 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2 test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85 test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2 test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85 test mathop-6.11 {compiled &: errors} -returnCodes error -body { & x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.13 {compiled &: errors} -returnCodes error -body { & 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError @@ -419,32 +419,32 @@ namespace eval ::testmathop { test mathop-6.22 {interpreted &} { $op 3 7 6 } 2 test mathop-6.23 {interpreted &} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2 test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85 test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2 test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85 test mathop-6.29 {interpreted &: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.31 {interpreted &: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -487,32 +487,32 @@ namespace eval ::testmathop { test mathop-7.4 {compiled |} { | 3 7 6 } 7 test mathop-7.5 {compiled |} -returnCodes error -body { | 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110 test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503 test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110 test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.11 {compiled |: errors} -returnCodes error -body { | x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.13 {compiled |: errors} -returnCodes error -body { | 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError @@ -529,32 +529,32 @@ namespace eval ::testmathop { test mathop-7.22 {interpreted |} { $op 3 7 6 } 7 test mathop-7.23 {interpreted |} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110 test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503 test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110 test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.29 {interpreted |: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.31 {interpreted |: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -597,32 +597,32 @@ namespace eval ::testmathop { test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2 test mathop-8.5 {compiled ^} -returnCodes error -body { ^ 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110 test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333 test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.11 {compiled ^: errors} -returnCodes error -body { ^ x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.13 {compiled ^: errors} -returnCodes error -body { ^ 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError @@ -639,32 +639,32 @@ namespace eval ::testmathop { test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2 test mathop-8.23 {interpreted ^} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110 test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333 test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.29 {interpreted ^: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.31 {interpreted ^: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -775,13 +775,13 @@ test mathop-20.6 { one arg, error } { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string as operand of \"$op\"\ + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric string}" } } foreach op {+ * / & | ^ **} { lappend res [TestOp $op NaN 1] - lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\ + lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} @@ -850,15 +850,15 @@ test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { @@ -965,9 +965,9 @@ test mathop-22.4 { unary ops, bad values } { set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 @@ -1080,15 +1080,15 @@ test mathop-24.3 { binary ops, bad values } { set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] @@ -1266,9 +1266,9 @@ test mathop-25.41 { exp operator errors } { lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 @@ -1342,6 +1342,46 @@ test mathop-26.2 { misc ops, corner cases } { set res } [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616] +test mathop-27.1 {lt operator} {::tcl::mathop::lt} 1 +test mathop-27.2 {lt operator} {::tcl::mathop::lt a} 1 +test mathop-27.3 {lt operator} {::tcl::mathop::lt a b} 1 +test mathop-27.4 {lt operator} {::tcl::mathop::lt b a} 0 +test mathop-27.5 {lt operator} {::tcl::mathop::lt a a} 0 +test mathop-27.6 {lt operator} {::tcl::mathop::lt a b c} 1 +test mathop-27.7 {lt operator} {::tcl::mathop::lt b a c} 0 +test mathop-27.8 {lt operator} {::tcl::mathop::lt a c b} 0 +test mathop-27.9 {lt operator} {::tcl::mathop::lt 012 0x0} 1 + +test mathop-28.1 {le operator} {::tcl::mathop::le} 1 +test mathop-28.2 {le operator} {::tcl::mathop::le a} 1 +test mathop-28.3 {le operator} {::tcl::mathop::le a b} 1 +test mathop-28.4 {le operator} {::tcl::mathop::le b a} 0 +test mathop-28.5 {le operator} {::tcl::mathop::le a a} 1 +test mathop-28.6 {le operator} {::tcl::mathop::le a b c} 1 +test mathop-28.7 {le operator} {::tcl::mathop::le b a c} 0 +test mathop-28.8 {le operator} {::tcl::mathop::le a c b} 0 +test mathop-28.9 {le operator} {::tcl::mathop::le 012 0x0} 1 + +test mathop-29.1 {gt operator} {::tcl::mathop::gt} 1 +test mathop-29.2 {gt operator} {::tcl::mathop::gt a} 1 +test mathop-29.3 {gt operator} {::tcl::mathop::gt a b} 0 +test mathop-29.4 {gt operator} {::tcl::mathop::gt b a} 1 +test mathop-29.5 {gt operator} {::tcl::mathop::gt a a} 0 +test mathop-29.6 {gt operator} {::tcl::mathop::gt c b a} 1 +test mathop-29.7 {gt operator} {::tcl::mathop::gt b a c} 0 +test mathop-29.8 {gt operator} {::tcl::mathop::gt a c b} 0 +test mathop-29.9 {gt operator} {::tcl::mathop::gt 0x0 012} 1 + +test mathop-30.1 {ge operator} {::tcl::mathop::ge} 1 +test mathop-30.2 {ge operator} {::tcl::mathop::ge a} 1 +test mathop-30.3 {ge operator} {::tcl::mathop::ge a b} 0 +test mathop-30.4 {ge operator} {::tcl::mathop::ge b a} 1 +test mathop-30.5 {ge operator} {::tcl::mathop::ge a a} 1 +test mathop-30.6 {ge operator} {::tcl::mathop::ge c b a} 1 +test mathop-30.7 {ge operator} {::tcl::mathop::ge b a c} 0 +test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0 +test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1 + if 0 { # Compare ops to expr bytecodes namespace import ::tcl::mathop::* @@ -1354,7 +1394,7 @@ if 0 { _X 3 4 5 set ::tcl_traceCompile 0 } - + # cleanup namespace delete ::testmathop namespace delete ::testmathop2 diff --git a/tests/misc.test b/tests/misc.test index 8f8516e..3fce454 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -5,9 +5,9 @@ # 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. @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 d34a483..6d2ba2c 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 @@ -16,7 +16,6 @@ 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." return @@ -55,8 +54,13 @@ namespace eval ::msgcat::test { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { +if {[package vsatisfies [package provide msgcat] 1.7]} { + set result [string tolower \ + [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] +} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] +} } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { @@ -194,6 +198,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -666,18 +692,18 @@ namespace eval ::msgcat::test { set msgdir3 [makeDirectory msgdir3] makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ l2.msg $msgdir2 - makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3 + makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3 # chained mcload - test msgcat-8.2 {mcflset} -setup { + test msgcat-8.2 {mcflset/mcflmset} -setup { variable locale [mclocale] mclocale l2 mcload $msgdir2 } -cleanup { mclocale $locale } -body { - return [mc k2][mc k3] - } -result v2v3 + return [mc k2][mc k3]--[mc k4][mc k5] + } -result v2v3--v4v5 removeFile l2.msg $msgdir2 removeDirectory msgdir2 @@ -688,7 +714,7 @@ namespace eval ::msgcat::test { test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src @@ -724,12 +750,34 @@ namespace eval ::msgcat::test { mcset foo k1 v1 } -cleanup { mclocale $locale + namespace delete ::foo } -body { - namespace eval ::msgcat::test::sub { + namespace eval ::foo { list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -exactnamespace k1] + [::msgcat::mcexists -namespace ::msgcat::test k1] } - } -result {1 0} + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + # Tests msgcat-10.*: [mcloadedlocales] @@ -811,13 +859,18 @@ namespace eval ::msgcat::test { test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { @@ -922,6 +975,30 @@ namespace eval ::msgcat::test { list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1073,8 +1150,212 @@ namespace eval ::msgcat::test { } -returnCodes 1\ -result {fail} + + # Tests msgcat-15.*: tcloo coverage + + # There are 4 use-cases, where 3 must be tested now: + # - namespace defined, in class definition, class defined oo, classless + + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result con2bar + + test msgcat-15.3 {mc in classless object} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + bar::ObjCur method1 + } -result con2bar + + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ + -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz + + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + } -cleanup { + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.5\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::baz + + + # Test msgcat-17.*: mcn command + + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar + + interp bgerror {} $bgerrorsaved + # Tests msgcat-18.*: [mcutil] + + test msgcat-18.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-18.2 {mcutil - wrong argument} -body { + mcutil junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} + + test msgcat-18.3 {mcutil - partial argument} -body { + mcutil getsystem + } -returnCodes 1\ + -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} + + test msgcat-18.4 {mcutil getpreferences - no argument} -body { + mcutil getpreferences + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getpreferences locale"} + + test msgcat-18.5 {mcutil getpreferences - DE_de} -body { + mcutil getpreferences DE_de + } -result {de_de de {}} + + test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body { + mcutil getsystemlocale DE_de + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getsystemlocale"} + + # The result is system dependent + # So just test if it runs + # The environment variable version was test with test 0.x + test msgcat-18.7 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/namespace-old.test b/tests/namespace-old.test index e4715f8..468c648 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::* } @@ -631,13 +631,13 @@ test namespace-old-8.1 {traces work across namespace boundaries} { variable status lappend status "$op: $name1" } - trace variable foo::x rwu [namespace code monitor] + trace add variable foo::x {read write unset} [namespace code monitor] } set test_ns_trace::foo::x "yes!" set test_ns_trace::foo::x unset test_ns_trace::foo::x namespace eval test_ns_trace { set status } -} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}} +} {{write: test_ns_trace::foo::x} {read: test_ns_trace::foo::x} {unset: test_ns_trace::foo::x}} # ----------------------------------------------------------------------- # TEST: imported commands diff --git a/tests/namespace.test b/tests/namespace.test index 08531e4..c98ad4a 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -6,8 +6,8 @@ # 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. @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { 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 @@ -182,8 +182,8 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} } {} test namespace-7.7 {Bug 1655305} -setup { interp create child - # Can't invoke through the ensemble, since deleting the global namespace - # (indirectly, via deleting ::tcl) deletes the ensemble. + # Can't invoke through the ensemble, since deleting ::tcl + # (indirectly, via deleting the global namespace) deletes the ensemble. child eval {rename ::tcl::info::commands ::infocommands} child hide infocommands child eval { @@ -207,10 +207,72 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols. namespace delete ns1 } -result {} + +test namespace-7.9 { + Bug e39cb3f462631a99 + + A namespace being deleted should not be removed from other namespace paths + until the contents of the namespace are entirely removed. +} -setup { + + + + +} -body { + + variable res {} + + + namespace eval ns1 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + + namespace eval ns1a { + namespace path [namespace parent]::ns1 + + proc t1 {old new op} { + $old t1 + } + } + + namespace eval ns2 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + namespace eval ns2a { + namespace path [namespace parent]::ns2 + + proc t1 {old new op} { + [namespace tail $old] t2 + } + } + + + trace add command ns1::p1 delete ns1a::t1 + namespace delete ns1 + + trace add command ns2::p1 delete ns2a::t1 + namespace delete ns2 + + return $res + +} -cleanup { + namespace delete ns1a + namespace delete ns2a + unset res +} -result {t1 t2} + + + test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -2741,7 +2803,11 @@ test namespace-51.12 {name resolution path control} -body { catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } -test namespace-51.13 {name resolution path control} -body { +test namespace-51.13 { + name resolution path control + when the trace fires, ns_2 is being deleted but isn't gone yet, and is + still visible for the trace +} -body { set ::result {} namespace eval ::test_ns_1 { proc foo {} {lappend ::result 1} @@ -2764,8 +2830,7 @@ test namespace-51.13 {name resolution path control} -body { } bar } - # Should the result be "2 {} {2 3 2 1}" instead? -} -result {2 {} {2 3 1 1}} -cleanup { +} -result {2 {} {2 3 2 1}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} @@ -3362,12 +3427,16 @@ test namespace-56.6 { Namespace deletion traces on both the original routine and the imported routine should run without any memory error under a debug build. } -body { - variable res 0 + variable res {} proc ondelete {old new op} { - $old + variable res + set tail [namespace tail $old] + set up [namespace tail [namespace qualifiers $old]] + lappend res [list $up $tail] } + namespace eval ns1 {} { namespace export * proc p1 {} { @@ -3378,17 +3447,18 @@ test namespace-56.6 { } namespace eval ns2 {} { - namespace import ::ns1::p1 + namespace import [namespace parent]::ns1::p1 trace add command p1 delete ondelete } namespace delete ns1 namespace delete ns2 + after 1 return $res } -cleanup { unset res rename ondelete {} -} -result 2 +} -result {{ns1 p1} {ns2 p1}} test namespace-57.0 { diff --git a/tests/notify.test b/tests/notify.test index 7375f83..840ad31 100644 --- a/tests/notify.test +++ b/tests/notify.test @@ -8,7 +8,7 @@ # 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. @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 7cf06d1..8296569 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -4,7 +4,7 @@ # 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 e49a908..64a1d5b 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -5,8 +5,8 @@ # 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. @@ -17,21 +17,21 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] + +source [file join [file dirname [info script]] tcltests.tcl] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] -test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {testobj deprecated} { set r 1 foreach {t} { - {array search} bytearray bytecode cmdName dict - end-offset regexp string } { @@ -53,15 +53,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] @@ -262,10 +253,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 "" @@ -487,11 +478,11 @@ test obj-26.1 {UpdateStringOfInt} testobj { lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-27.1 {Tcl_NewLongObj} testobj { +test obj-27.1 {Tcl_NewWideObj} testobj { set result "" lappend result [testobj freeallvars] - testintobj setmaxlong 1 - lappend result [testintobj ismaxlong 1] + testintobj setmax 1 + lappend result [testintobj ismax 1] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 1 int 1} @@ -500,7 +491,7 @@ test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testintobj setint 1 77] ;# makes existing obj int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} @@ -508,32 +499,32 @@ test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] - lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testintobj setint 1 77] ;# makes existing obj int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj { +test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj { set result "" - lappend result [testintobj setlong 1 22] - lappend result [testintobj mult10 1] ;# gets existing long int rep + lappend result [testintobj setint 1 22] + lappend result [testintobj mult10 1] ;# gets existingint rep } {22 220} -test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj { +test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj { set result "" - lappend result [testintobj setlong 1 477] + lappend result [testintobj setint 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj { +test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj { set result "" lappend result [teststringobj set 1 abc] - lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj { +test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] - lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} @@ -551,44 +542,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { @@ -597,34 +550,34 @@ test obj-32.1 {freeing very large object trees} { unset x } {} -test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} -test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 4294967296} -test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +} {1 4294967296} +test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} -test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} -test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 -4294967296} +} {1 -4294967296} test obj-34.1 {mp_iseven} testobj { set result "" diff --git a/tests/oo.test b/tests/oo.test index abd5d31..291060d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,24 +2,22 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-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.1.0 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } - # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. - testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -40,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 @@ -81,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 } @@ -92,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 } @@ -111,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 {} @@ -131,11 +129,11 @@ test oo-1.1 {basic test of OO functionality: no classes} { } {::foo {} a b c 3 {} {}} test oo-1.2 {basic test of OO functionality: no classes} -body { oo::define oo::object method missingArgs -} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\"" test oo-1.3 {basic test of OO functionality: no classes} { catch {oo::define oo::object method missingArgs} set errorInfo -} "wrong # args: should be \"oo::define oo::object method name args body\" +} "wrong # args: should be \"oo::define oo::object method name ?option? args body\" while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { @@ -365,26 +363,27 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { + set initials {::oo::object ::oo::class ::oo::Slot} foreach cmd {instances subclasses mixins superclass} { - foreach initial {object class Slot} { - lappend x [info class $cmd ::oo::$initial] + foreach initial $initials { + lappend x [info class $cmd $initial] } } - foreach initial {object class Slot} { - lappend x [info object class ::oo::$initial] + foreach initial $initials { + lappend x [info object class $initial] } return $x - }] {lsort $x} + }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -515,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 { @@ -535,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 { @@ -814,6 +813,76 @@ test oo-4.6 {export creates proper method entries} -setup { } -cleanup { testClass destroy } -result ok +test oo-4.7 {basic test of OO functionality: method -export flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method Foo {} { + lappend ::result Foo + return foo + } + method Bar -export {} { + lappend ::result Bar + return bar + } + } + lappend result [catch {$o Foo} msg] $msg + lappend result [$o Bar] +} -cleanup { + $o destroy +} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar} +test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -unexport {} { + lappend ::result bar + return Bar + } + } + lappend result [$o foo] + lappend result [catch {$o bar} msg] $msg +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}} +test oo-4.9 {basic test of OO functionality: method -private flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -private {} { + lappend ::result bar + return Bar + } + export eval + method gorp {} { + my bar + } + } + lappend result [$o foo] + lappend result [catch {$o bar} msg] $msg + lappend result [catch {$o eval my bar} msg] $msg + lappend result [$o gorp] +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar} +test oo-4.10 {basic test of OO functionality: method flag parsing} -setup { + set o [oo::object new] +} -body { + oo::objdefine $o method foo -gorp xyz {return Foo} +} -returnCodes error -cleanup { + $o destroy +} -result {bad export flag "-gorp": must be -export, -private, or -unexport} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] @@ -1670,10 +1739,10 @@ test oo-11.6.4 { instances } -body { oo::class create obj1 - ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + ::oo::define obj1 {self mixin [self]} ::oo::copy obj1 obj2 - ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]} + ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 rename obj3 {} @@ -2389,7 +2458,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2519,6 +2588,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { } -cleanup { meta destroy } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} +test oo-16.15 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + info object creationid [cls new] +} -cleanup { + cls destroy +} -result {^\d+$} -match regexp +test oo-16.16 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set obj [cls new] + set id [info object creationid $obj] + rename $obj gorp + set id2 [info object creationid gorp] + list $id $id2 +} -cleanup { + cls destroy +} -result {^(\d+) \1$} -match regexp +test oo-16.17 {OO: object introspection: creationid #500} -body { + info object creationid nosuchobject +} -returnCodes error -result {nosuchobject does not refer to an object} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.18.1 {OO: object introspection: creationid #500} -body { + info object creationid oo::object gorp +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.19 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.20 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + $o1 destroy + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.21 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [oo::copy $o1]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal test oo-17.1 {OO: class introspection} -body { info class @@ -2541,7 +2677,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -2640,6 +2776,7 @@ test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup { c destroy } -result $stdmethods + test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo @@ -3824,7 +3961,7 @@ 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 parent { + oo::class create Parent { superclass Super variable member1 member2 constructor {} { @@ -3850,7 +3987,7 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { method result {} {return $result} } } -body { - [[parent new] getChild] result + [[Parent new] getChild] result } -cleanup { Super destroy } -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} @@ -3957,6 +4094,11 @@ proc SampleSlotSetup script { lappend ops [info level] Set $lst return } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } } } append script0 \n$script @@ -3991,7 +4133,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3999,7 +4141,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -4007,7 +4149,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -prepend g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} +test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -remove c a] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] @@ -4030,7 +4188,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} -}] -result {{} unknown {1 Set destroy 1 Set unknown}} +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { @@ -4039,7 +4197,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -set, contents or ops} + {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -4062,32 +4220,75 @@ test oo-34.1 {TIP 380: slots - presence} -setup { } -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot} test oo-34.2 {TIP 380: slots - presence} { lsort [info class instances oo::Slot] -} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} +} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} proc getMethods obj { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} +test oo-34.10 {TIP 516: slots - resolution} -setup { + oo::class create parent + set result {} + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + namespace eval 516test { + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + } +} -body { + # Must find the right classes when making the mixin + namespace eval 516test { + oo::define 516a { + mixin 516b 516c + } + } + lappend result [info class mixin 516test::516a] + # Must not remove class with just simple name match + oo::define 516test::516a { + mixin -remove 516b + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match + oo::define 516test::516a { + mixin -remove 516test::516c + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match even after renaming, but only + # with the renamed name; it is a slot of classes, not strings! + rename 516test::516b 516test::516d + oo::define 516test::516a { + mixin -remove 516test::516b + } + lappend result [info class mixin 516test::516a] + oo::define 516test::516a { + mixin -remove 516test::516d + } + lappend result [info class mixin 516test::516a] +} -cleanup { + parent destroy +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { @@ -4159,8 +4360,6 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} } -cleanup { base destroy } -result {{c d e} {c d e}} - - test oo-35.6 { Bug : teardown of an object that is a class that is an instance of itself } -setup { @@ -4183,11 +4382,1110 @@ test oo-35.6 { rename obj {} } -result done +test oo-36.1 {TIP #470: introspection within oo::define} { + oo::define oo::object self +} ::oo::object +test oo-36.2 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls +} -body { + oo::define Cls self +} -cleanup { + Cls destroy +} -result ::Cls +test oo-36.3 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self] + } + return $result +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.4 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self {}] + } + return $result +} -cleanup { + Super destroy +} -result {} +test oo-36.5 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self self] + } +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls + set result uncalled +} -body { + Cls create obj + oo::objdefine obj { + ::set ::result [self] + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self anything + } +} -returnCodes error -cleanup { + Cls destroy +} -result {wrong # args: should be "self"} +test oo-36.9 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::define::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + list [oo::define Cls testself] $result +} -cleanup { + Cls destroy + catch {rename oo::define::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} +test oo-36.10 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::objdefine::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + Cls create obj + list [oo::objdefine obj testself] $result +} -cleanup { + Cls destroy + catch {rename oo::objdefine::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} + +test oo-37.1 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private ::error "this is an error" + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.2 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private { + ::error "this is an error" + } + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.3 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private ::error "this is an error" + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.4 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private { + ::error "this is an error" + } + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.5 {TIP 500: private command can't be used outside definitions} -body { + oo::define::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} +test oo-37.6 {TIP 500: private command can't be used outside definitions} -body { + oo::objdefine::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} + +test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private variable x + constructor {} { + set x 1 + } + method getA {} { + return $x + } + } + oo::class create clsB { + superclass clsA + private { + variable x + } + constructor {} { + set x 2 + next + } + method getB {} { + return $x + } + } + oo::class create clsC { + superclass clsB + variable x + constructor {} { + set x 3 + next + } + method getC {} { + return $x + } + } + clsC create obj + oo::objdefine obj { + private { + variable x + } + method setup {} { + set x 4 + } + method getO {} { + return $x + } + } + obj setup + list [obj getA] [obj getB] [obj getC] [obj getO] \ + [lsort [string map [list [info object creationid clsA] CLASS-A \ + [info object creationid clsB] CLASS-B \ + [info object creationid obj] OBJ] \ + [info object vars obj]]] +} -cleanup { + parent destroy +} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} +test oo-38.2 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 + variable x2 + } + variable y1 y2 + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + } + list [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables obj]] \ + [lsort [info object variables obj -private]] +} -cleanup { + parent destroy +} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private { + variable x + } + method getx {} { + set x 1 + my varname x + } + method readx {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method gety {} { + set x 1 + my varname x + } + method ready {} { + return $x + } + } + clsB create obj + set [obj getx] 2 + set [obj gety] 3 + list [obj readx] [obj ready] +} -cleanup { + parent destroy +} -result {2 3} +test oo-38.4 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 x2 + } + variable y1 y2 + constructor {} { + variable z boo + set x1 a + set y1 c + } + method list {} { + variable z + set ok 1 + list [info locals] [lsort [info vars]] [info exist x2] + } + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + method init {} { + # Because we don't have a constructor to do this setup for us + set a1 p + set b1 r + } + method list {} { + variable z + set yes 1 + list {*}[next] [info locals] [lsort [info vars]] [info exist a2] + } + } + obj init + obj list +} -cleanup { + parent destroy +} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { + oo::class create parent +} -body { + oo::class create cls1 { + superclass parent + private variable x + method abc val { + my variable x + set x $val + } + method def val { + my variable y + set y $val + } + method get1 {} { + my variable x y + return [list $x $y] + } + } + oo::class create cls2 { + superclass cls1 + private variable x + method x-exists {} { + return [info exists x],[uplevel 1 {info exists x}] + } + method ghi x { + # Additional instrumentation to show that we're not using the + # resolved variable until we ask for it; the argument nixed that + # happening by default. + set val $x + set before [my x-exists] + unset x + set x $val + set mid [my x-exists] + unset x + set mid2 [my x-exists] + my variable x + set x $val + set after [my x-exists] + return "$before;$mid;$mid2;$after" + } + method jkl val { + my variable y + set y $val + } + method get2 {} { + my variable x y + return [list $x $y] + } + } + cls2 create a + a abc 123 + a def 234 + set tmp [a ghi 345] + a jkl 456 + list $tmp [a get1] [a get2] +} -cleanup { + parent destroy +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} + +test oo-39.1 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + clsA create obj + obj act + list [obj x] [catch {obj step} msg] $msg +} -cleanup { + parent destroy +} -result {7 1 {unknown method "step": must be act, destroy or x}} +test oo-39.2 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method step {} { + incr x 5 + } + } + clsB create obj + obj act + list [obj x] [obj step] +} -cleanup { + parent destroy +} -result {7 12} +test oo-39.3 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my Step + my Step + my Step + return + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method Step {} { + incr x 5 + } + } + clsB create obj + obj act + set result [obj x] + oo::define clsA { + private { + method Step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {16 22} +test oo-39.4 {TIP 500: private methods internal call; instance private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + return + } + method step {} { + incr x + } + method x {} { + return $x + } + } + clsA create obj + obj act + set result [obj x] + oo::objdefine obj { + variable x + private { + method step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] + oo::objdefine obj { + method act {} { + my step + next + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {2 3 6} +test oo-39.5 {TIP 500: private methods internal call; cross object} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other x]} + } + } + cls create a 1 + cls create b 2 + cls create c 1 + list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg +} -cleanup { + parent destroy +} -result {0 0 1 1 {unknown method "x": must be destroy or equal}} +test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other y]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[[self] y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x} +test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my x] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + } + oo::class create cls2 { + superclass cls + private method chain {} { + next + } + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + } + cls create a + cls2 create b + list [a chain] [b chain] [b chain2] [b chain3] +} -cleanup { + parent destroy +} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} +test oo-39.12 {TIP 500: private methods; introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + private method abc {} {} + } + oo::class create cls2 { + superclass cls + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + private method def {} {} + unexport chain3 + } + cls create a + cls2 create b + oo::objdefine b { + private method ghi {} {} + method ABC {} {} + method foo {} {} + } + set scopes {public unexported private} + list a: [lmap s $scopes {info object methods a -scope $s}] \ + b: [lmap s $scopes {info object methods b -scope $s}] \ + cls: [lmap s $scopes {info class methods cls -scope $s}] \ + cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \ +} -cleanup { + parent destroy +} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} + +test oo-40.1 {TIP 500: private and self} -setup { + oo::class create cls +} -body { + oo::define cls { + self { + private { + variable a + } + variable b + } + private { + self { + variable c + } + variable d + } + variable e + } + list \ + [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables cls]] \ + [lsort [info object variables cls -private]] +} -cleanup { + cls destroy +} -result {e d b {a c}} +test oo-40.2 {TIP 500: private and export} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + export foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo foo {} {}} +test oo-40.3 {TIP 500: private and unexport} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + unexport foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: myclass command, including class morphing} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method count {} { + my variable c + incr c + } + method act {} { + myclass count + } + } + cls1 create x + lappend result [x act] [x act] + cls1 create y + lappend result [y act] [y act] [x act] + oo::class create cls2 { + superclass cls1 + self method count {} { + my variable d + expr {1.0 * [incr d]} + } + } + oo::objdefine x {class cls2} + lappend result [x act] [y act] [x act] [y act] +} -cleanup { + parent destroy +} -result {1 2 3 4 5 1.0 6 2.0 7} +test oo-41.2 {TIP 478: myclass command cleanup} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method hi {} { + return "this is [self]" + } + method hi {} { + return "this is [self]" + } + } + cls1 create x + rename [info object namespace x]::my foo + rename [info object namespace x]::myclass bar + lappend result [cls1 hi] [x hi] [foo hi] [bar hi] + x destroy + lappend result [catch {foo hi}] [catch {bar hi}] +} -cleanup { + parent destroy +} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} +test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method Hi {} { + return "this is [self]" + } + forward poke myclass Hi + } + cls1 create x + lappend result [catch {cls1 Hi}] [x poke] +} -cleanup { + parent destroy +} -result {1 {this is ::cls1}} + +test oo-42.1 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object +} {} +test oo-42.2 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -class +} {} +test oo-42.3 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -instance +} ::oo::objdefine +test oo-42.4 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -gorp +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-42.5 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -class x +} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} +test oo-42.6 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class +} ::oo::define +test oo-42.7 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -class +} ::oo::define +test oo-42.8 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -instance +} {} +test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + oo::class create foo { + superclass parent + self class foocls + } + oo::define foo { + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -class foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -instance foodef + } + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + namespace delete foodef +} -result {invalid command name "sparkle"} +test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + namespace delete foodef + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {invalid command name "sparkle"} +test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain result +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace delete foodef + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + lappend result [catch {oo::define foo sparkle} msg] $msg +} -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {0 ok 1 {invalid command name "sparkle"} 0 ok} +test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {x} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + } + oo::define foo spar gorp +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foo { + superclass parent + definitionnamespace -instance foodef + } + oo::objdefine [foo new] { + method x y z + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.9 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -gorp foodef + } +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-43.10 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -class foodef x + } +} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} +test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { + catch {namespace delete ::no_such_ns} +} -body { + oo::class create foo { + definitionnamespace -class ::no_such_ns + } +} -returnCodes error -result {namespace "::no_such_ns" not found} +test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass oo::class parent + } + list [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace foodef] \ + [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace {}] \ + [info class definitionnamespace foo] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} +test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass parent + } + list [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance foodef] \ + [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance {}] \ + [info class definitionnamespace foo -instance] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} cleanupTests return # Local Variables: -# MODE: Tcl +# mode: tcl # End: diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 726757b..8d8cf45 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -2,12 +2,12 @@ # 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.1.0 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooProp.test b/tests/ooProp.test new file mode 100644 index 0000000..8120f88 --- /dev/null +++ b/tests/ooProp.test @@ -0,0 +1,885 @@ +# This file contains a collection of tests for Tcl's built-in object system, +# specifically the parts that support configurable properties on objects. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 2019-2020 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcl::oo 1.0.3 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +test ooProp-1.1 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties c] [info class properties c -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test ooProp-1.2 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties c -all] [info class properties c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test ooProp-1.3 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties c] [info class properties c -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test ooProp-1.4 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties c -all] [info class properties c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test ooProp-1.5 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + oo::define d ::oo::configuresupport::readableproperties -set x y z + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + oo::define d ::oo::configuresupport::readableproperties -set r p q + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a h + oo::define d ::oo::configuresupport::readableproperties -set g h g + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define d ::oo::configuresupport::readableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} +test ooProp-1.6 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + oo::define d ::oo::configuresupport::writableproperties -set x y z + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + oo::define d ::oo::configuresupport::writableproperties -set r p q + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a h + oo::define d ::oo::configuresupport::writableproperties -set g h g + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define d ::oo::configuresupport::writableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} +test ooProp-1.7 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set + lappend result [info object properties o] [info object properties o -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} +test ooProp-1.8 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set + lappend result [info object properties o] [info object properties o -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} +test ooProp-1.9 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b + oo::define d ::oo::configuresupport::readableproperties -set c d + oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e + lappend result [info object properties o -all] [info object properties o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c d e f} {} {a b c d e f} {}} +test ooProp-1.10 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b + oo::define d ::oo::configuresupport::writableproperties -set c d + oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e + lappend result [info object properties o -all] [info object properties o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c d e f} {} {a b c d e f}} +test ooProp-1.11 {TIP 558: properties: core support cache} -setup { + oo::class create parent + unset -nocomplain result +} -body { + oo::class create m { + superclass parent + ::oo::configuresupport::readableproperties -set a + ::oo::configuresupport::writableproperties -set c + } + oo::class create c { + superclass parent + ::oo::configuresupport::readableproperties -set b + ::oo::configuresupport::writableproperties -set d + } + c create o + lappend result [info object properties o -all -readable] \ + [info object properties o -all -writable] + oo::objdefine o mixin m + lappend result [info object properties o -all -readable] \ + [info object properties o -all -writable] +} -cleanup { + parent destroy +} -result {b d {a b} {c d}} + +test ooProp-2.1 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + variable x y + method report {} { + lappend ::result "x=$x, y=$y" + } + } + set pt [Point new -x 3] + $pt report + $pt configure -y 4 + $pt report + lappend result [$pt configure -x],[$pt configure -y] [$pt configure] +} -cleanup { + parent destroy +} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} +test ooProp-2.2 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + set pt [3DPoint new -x 3 -y 4 -z 5] + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} +test ooProp-2.3 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + set pt [Point new -x 3 -y 4] + oo::objdefine $pt property z + $pt configure -z 5 + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} +test ooProp-2.4 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x or -y} +test ooProp-2.5 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + [3DPoint new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x, -y, or -z} +test ooProp-2.6 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point create p] configure -x 1 -y +} -returnCodes error -cleanup { + parent destroy +} -result {wrong # args: should be "::p configure ?-option value ...?"} +test ooProp-2.7 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind writable + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + Point create p + list [p configure -y ok] [catch {p configure -y} msg] $msg +} -cleanup { + parent destroy +} -result {{} 1 {property "-y" is write only}} +test ooProp-2.8 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind readable + constructor args { + my configure -x 0 {*}$args + variable y 123 + } + } + Point create p + list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg +} -cleanup { + parent destroy +} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} + +test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<}} +test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } y -kind readable -get {return $xyz} + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< [pt configure -y] +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<} 15} +test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property -x -get {return $xyz} + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "-x": must not begin with -} +test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property "x y" + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x y": must be a simple word} +test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property ::x + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "::x": must not contain namespace separators} +test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x( + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x(": must not contain parentheses} +test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x) + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x)": must not contain parentheses} +test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -get option} +test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -kind + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing kind value to go with -kind option} +test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get {} -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {} -get {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -kind gorp + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad kind "gorp": must be readable, readwrite, or writable} +test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -k reada -g {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property {*}{ + x -kind writable + y -get {return ok} + } + } + [Point new] configure -y +} -cleanup { + parent destroy +} -result ok +test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + variable xy + property x -kind readable -get {return $xy} + property x -kind writable -set {set xy $value} + } + Point create pt + list [catch { + pt configure -x ok + } msg] $msg [catch { + pt configure -x + } msg] $msg [catch { + pt configure -y 1 + } msg] $msg +} -cleanup { + parent destroy +} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} +test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code continue} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a continue} +test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure -x + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code break} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a break} +test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code continue} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a continue} +test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {error "boo"} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -level 2 ok} + } + apply {{} { + [Point new] configure -x gorp + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + private property var + } + Point create pt + pt configure -var ok + pt configure -var +} -cleanup { + parent destroy +} -result ok + +test ooProp-4.1 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property -x}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property name "-x": must not begin with - + while executing +"property -x" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}} +test ooProp-4.2 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -get}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -get option + while executing +"property x -get" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -get}"} {TCL WRONGARGS}} +test ooProp-4.3 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -set}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -set option + while executing +"property x -set" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -set}"} {TCL WRONGARGS}} +test ooProp-4.4 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing kind value to go with -kind option + while executing +"property x -kind" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind}"} {TCL WRONGARGS}} +test ooProp-4.5 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad kind "gorp": must be readable, readwrite, or writable + while executing +"property x -kind gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}} +test ooProp-4.6 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad option "-gorp": must be -get, -kind, or -set + while executing +"property x -gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}} +test ooProp-4.7 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}} +test ooProp-4.8 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp blarg} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/ooUtil.test b/tests/ooUtil.test new file mode 100644 index 0000000..f41c668 --- /dev/null +++ b/tests/ooUtil.test @@ -0,0 +1,563 @@ +# This file contains a collection of tests for functionality originally +# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs +# the tests and generates output for errors. No output means no errors were +# found. +# +# Copyright © 2014-2016 Andreas Kupries +# Copyright © 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcl::oo 1.3.0 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +test ooUtil-1.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -result {::Table called with arguments: foo bar} +test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { + namespace eval ::testns {} +} -body { + namespace eval ::testns { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -result {::testns::Table called with arguments: foo bar} +test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} +test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} +test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + set t [Table new] + $t find 1 2 3 +} -cleanup { + parent destroy +} -result {::Table called with arguments: 1 2 3} +test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + unexport find + } + set t [Table new] + $t find 1 2 3 +} -returnCodes error -cleanup { + parent destroy +} -match glob -result {unknown method "find": must be *} +test ooUtil-1.7 {} -setup { + oo::class create parent +} -body { + oo::class create Foo { + superclass parent + classmethod bar {} { + puts "This is in the class; self is [self]" + my meee + } + classmethod meee {} { + puts "This is meee" + } + } + oo::class create Grill { + superclass Foo + classmethod meee {} { + puts "This is meee 2" + } + } + list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] +} -cleanup { + parent destroy +} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" +# Two tests to confirm that we correctly initialise the scripted part of TclOO +# in child interpreters. This is slightly tricky at the implementation level +# because we cannot count on either [source] or [open] being available. +test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { + set childinterp [interp create] +} -body { + $childinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is not the parent interpreter + list [Table find foo bar] [info globals childinterp] + } +} -cleanup { + interp delete $childinterp +} -result {{::Table called with arguments: foo bar} {}} +test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { + set safeinterp [interp create -safe] +} -body { + $safeinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is a (basic) safe interpreter + list [Table find foo bar] [info commands source] + } +} -cleanup { + interp delete $safeinterp +} -result {{::Table called with arguments: foo bar} {}} + +test ooUtil-2.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test ooUtil-2.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 + +test ooUtil-3.1 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + proc foobar-3.1 {} {return ok} + } + method calls {} { + list [catch foobar-3.1 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.1] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.1"} ok} +test ooUtil-3.2 {TIP 478: class variables} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + variable x 123 + } + method call {} { + classvariable x + incr x + } + } + cls create a + cls create b + cls create c + list [a call] [b call] [c call] [a call] [b call] [c call] +} -cleanup { + parent destroy +} -result {124 125 126 127 128 129} +test ooUtil-3.3 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.3 {}} +} -body { + oo::class create ::cls { + superclass parent + initialize { + proc foobar-3.3 {} {return ok} + } + method calls {} { + list [catch foobar-3.3 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.3] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.3"} ok} +test ooUtil-3.4 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::appendToResultVar {}} + proc ::appendToResultVar args { + lappend ::result {*}$args + } + set result {} +} -body { + trace add execution oo::define::initialise enter appendToResultVar + oo::class create ::cls { + superclass parent + initialize {proc xyzzy {} {}} + } + return $result +} -cleanup { + catch { + trace remove execution oo::define::initialise enter appendToResultVar + } + rename ::appendToResultVar {} + parent destroy +} -result {{initialize {proc xyzzy {} {}}} enter} +test ooUtil-3.5 {TIP 478: class initialisation} -body { + oo::define oo::object { + ::list [::namespace which initialise] [::namespace which initialize] \ + [::namespace origin initialise] [::namespace origin initialize] + } +} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} + +test ooUtil-4.1 {TIP 478: singleton} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + set x [xyz new] + set y [xyz new] + set z [xyz new] + set code [catch {$x destroy} msg] + set p [xyz new] + lappend code [catch {rename $x ""}] + set q [xyz new] + string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] +} -cleanup { + parent destroy +} -result {1 0 ONE ONE ONE ONE TWO TWO} +test ooUtil-4.2 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + [xyz new] destroy +} -returnCodes error -cleanup { + parent destroy +} -result {may not destroy a singleton object} +test ooUtil-4.3 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + oo::copy [xyz new] +} -returnCodes error -cleanup { + parent destroy +} -result {may not clone a singleton object} + + +test ooUtil-5.1 {TIP 478: abstract} -setup { + oo::class create parent +} -body { + oo::abstract create xyz { + superclass parent + method foo {} {return 123} + } + oo::class create pqr { + superclass xyz + method bar {} {return 456} + } + set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] + set x [pqr new] + set y [pqr create ::y] + lappend codes [$x foo] [$x bar] $y +} -cleanup { + parent destroy +} -result {1 1 1 123 456 ::y} + +test ooUtil-6.1 {TIP 478: classvariable} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + initialise { + variable x 1 y 2 + } + method a {} { + classvariable x + incr x + } + method b {} { + classvariable y + incr y + } + method c {} { + classvariable x y + list $x $y + } + } + set p [xyz new] + set q [xyz new] + set result [list [$p c] [$q c]] + $p a + $q b + lappend result [[xyz new] c] +} -cleanup { + parent destroy +} -result {{1 2} {1 2} {2 3}} +test ooUtil-6.2 {TIP 478: classvariable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable x(1) + incr x(1) + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} +test ooUtil-6.3 {TIP 478: classvariable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable ::x + incr x + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} + +test ooUtil-7.1 {TIP 478: link calling pattern} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + method Bar {} {return "in bar of [self]"} + method Grill {} {return "in grill of [self]"} + export eval + constructor {} { + link foo + link {bar Bar} {grill Grill} + } + } + cls create o + o eval {list [foo] [bar] [grill]} +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} +test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + constructor {cmd} { + link [list ::$cmd foo] + } + } + cls create o pqr + list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} + +# Tests that verify issues detected with the tcllib version of the code +test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { + oo::class create animal {} + namespace eval ::ooutiltest { + oo::class create pet { superclass animal } + } +} -body { + namespace eval ::ooutiltest { + oo::class create dog { superclass pet } + } +} -cleanup { + namespace delete ooutiltest + rename animal {} +} -result {::ooutiltest::dog} +test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { + oo::class create TestClass { + superclass oo::class + self method create {name ignore body} { + next $name $body + } + } +} -body { + TestClass create okay {} {} +} -cleanup { + rename TestClass {} +} -result {::okay} + +cleanupTests +return + +# Local Variables: +# fill-column: 78 +# mode: tcl +# End: diff --git a/tests/opt.test b/tests/opt.test index 419e6bf..2d304c6 100644 --- a/tests/opt.test +++ b/tests/opt.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) 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. diff --git a/tests/package.test b/tests/package.test index 641ce49..134b4f7 100644 --- a/tests/package.test +++ b/tests/package.test @@ -5,28 +5,34 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2011 Donal K. Fellows +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.3 + package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + # Do all this in a child interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoChildInterpreter $i {*}$argv +catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create @@ -134,7 +140,7 @@ test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -144,7 +150,7 @@ test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -154,7 +160,7 @@ test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -164,7 +170,7 @@ test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -174,7 +180,7 @@ test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t @@ -233,7 +239,7 @@ test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -251,7 +257,7 @@ test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} @@ -278,7 +284,7 @@ test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} @@ -569,15 +575,24 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} -test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { + testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -587,7 +602,7 @@ test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -597,17 +612,19 @@ test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} -test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} { +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable package forget t + set x xxx +} -body { foreach i {1.2b1 1.1} { package ifneeded t $i "set x $i; package provide t $i" } - set x xxx package require t set x -} {1.1} +} -result {1.1} test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { package forget t } -body { @@ -625,28 +642,51 @@ test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} @@ -654,6 +694,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 @@ -672,28 +715,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t @@ -706,18 +776,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide @@ -848,7 +931,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} @@ -1255,9 +1338,9 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} { +test package-13.0 {package prefer defaults} -body { prefer -} stable +} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer @@ -1272,15 +1355,27 @@ test package-14.1 {bogus argument} -returnCodes error -body { package prefer foo } -result {bad preference "foo": must be latest or stable} -test package-15.0 {set, keep} {package prefer stable} stable -test package-15.1 {set stable, keep} {prefer stable} {stable stable} -test package-15.2 {set latest, change} {prefer latest} {stable latest} -test package-15.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} -test package-15.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} +test package-15.0 {set, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer} -result stable +test package-15.1 {set stable, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer stable} -result stable +test package-15.2 {set latest, change} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer latest} -result latest +test package-15.3 {set latest, keep} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer latest +} -result latest +test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer stable +} -result latest rename prefer {} diff --git a/tests/parse.test b/tests/parse.test index 39f3d1e..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 @@ -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 {}" @@ -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" diff --git a/tests/parseExpr.test b/tests/parseExpr.test index aded88a..c70c5e3 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -2,8 +2,8 @@ # 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. @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::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, @@ -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 @@ -85,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 @@ -882,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 @@ -902,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 " @@ -1046,9 +1046,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - catch {testexprparser 08 -1} m o - dict get $o -errorcode -} -result {TCL PARSE EXPR BADNUMBER OCTAL} + testexprparser 07 -1 +} -result {- {} 0 subexpr 07 1 text 07 0 {}} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode @@ -1067,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 0ac036b..44aa5d1 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -6,9 +6,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-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. @@ -19,10 +19,9 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] -testConstraint testbytestring [llength [info commands testbytestring]] # Save the argv value for restoration later set savedArgv $argv @@ -264,14 +263,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. diff --git a/tests/pid.test b/tests/pid.test index 47f753b..3f62457 100644 --- a/tests/pid.test +++ b/tests/pid.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-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. diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl index 9d89277..96542f9 100644 --- a/tests/pkgIndex.tcl +++ b/tests/pkgIndex.tcl @@ -1,3 +1,3 @@ #! /usr/bin/env tclsh -package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl] +package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl]
\ No newline at end of file diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index e047840..33add42 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -5,7 +5,7 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. if {"::tcltest" ni [namespace children]} { @@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl } "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" + test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can # delete the file and not get stuck because we're holding a reference to # it. # # This test depends on context from prior test, so repeat it. + set script \ "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" append script \n \ "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] -} {0 {}} +} "0 {}" if {[testConstraint $dll]} { file delete -force [file join $fullPkgPath [file tail $x]] diff --git a/tests/platform.test b/tests/platform.test index faab6d9..33aea3a 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -4,7 +4,7 @@ # 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. @@ -22,9 +22,10 @@ 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]] testConstraint testCPUID [llength [info commands testcpuid]] +testConstraint testlongsize [llength [info commands testlongsize]] test platform-1.0 {tcl_platform(engine)} { set tcl_platform(engine) @@ -39,16 +40,9 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { set result } {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} -# Test assumes twos-complement arithmetic, which is true of virtually -# everything these days. Note that this does *not* use wide(), and -# this is intentional since that could make Tcl's numbers wider than -# the machine-integer on some platforms... -test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { - set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}] - # Result must be the largest bit in a machine word, which this checks - # without assuming how wide the word really is - list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] -} {1 -1} +test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize { + expr {$tcl_platform(wordSize) == [testlongsize]} +} {1} # On Windows/UNIX, test that the CPU ID works diff --git a/tests/proc-old.test b/tests/proc-old.test index a92c6ab..2f0f417 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -7,9 +7,9 @@ # 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. @@ -137,25 +137,25 @@ test proc-old-3.7 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} set info {} - do {global a; trace var a(1) w t1} + do {global a; trace add var a(1) write t1} set a(1) 44 set info } 1 test proc-old-3.8 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} - trace var a(1) w t1 + trace add var a(1) write t1 set info {} - do {global a; trace vdelete a(1) w t1} + do {global a; trace remove var a(1) write t1} set a(1) 44 set info } {} test proc-old-3.9 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} - trace var a(1) w t1 - do {global a; trace vinfo a(1)} -} {{w t1}} + trace add var a(1) write t1 + do {global a; trace info var a(1)} +} {{write t1}} catch {unset a} test proc-old-30.1 {arguments and defaults} { @@ -349,7 +349,7 @@ test proc-old-5.16 {error conditions} { } proc tproc {} { set x 44 - trace var x u foo + trace add var x unset foo while {$x < 100} { error "Nested error" } @@ -361,7 +361,7 @@ test proc-old-5.16 {error conditions} { "error "Nested error"" (procedure "tproc" line 5) invoked from within -"tproc"} {foo was called: x {} u}} +"tproc"} {foo was called: x {} unset}} # The tests below will really only be useful when run under Purify or # some other system that can detect accesses to freed memory... diff --git a/tests/proc.test b/tests/proc.test index 72cb412..118dca1 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -7,8 +7,8 @@ # 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 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. @@ -17,8 +17,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands -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_*]} @@ -210,14 +211,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 +230,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 +242,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 +255,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 +268,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 +281,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 +294,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 +310,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 +322,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-4.10 { TclCreateProc, issue a8579d906a28, argument with no name diff --git a/tests/process.test b/tests/process.test new file mode 100644 index 0000000..4533108 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,341 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright © 2017 Frederic Bonnet +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +# Utilities +file delete [set path(test-signalfile) [makeFile {} test-signalfile]] +set path(test-signalfile2) [makeFile {} test-signalfile2] +# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted) +set path(sleep) [makeFile { + after [expr {[lindex $argv 0]*1000}] {set stop 1} + if {[set fn [lindex $::argv 1]] ne ""} { + close [open $fn w] + proc check {} { + if {![file exists $::fn]} { # exit signaled + after 10 {set ::stop 2} + } + after 10 check + } + after 10 check + } + vwait stop + exit +} sleep] + +proc wait_for_file {fn {timeout 10000}} { + if {![file exists $fn]} { + set toev [after $timeout {set found 0}] + proc check {fn} { + if {[file exists $fn]} { + set ::found 1 + return + } + after 10 [list check $fn] + } + after 10 [list check $fn] + vwait ::found + after cancel $toev + unset ::found + } + file exists $fn +} +proc signal_exit {fn {wait 1}} { + # wait for until file created if expected: + if {!$wait || [wait_for_file $fn]} { + # delete file to signal exit for child-process: + while {1} { + if {![catch { file delete $fn } msg opt] + || [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES} + } break + } + } +} + +set path(exit) [makeFile { + exit [lindex $argv 0] +} exit] + +# Basic syntax checking +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process subcommands} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} + +# Autopurge flag +# - Default state +test process-2.1 {autopurge default} -body { + tcl::process autopurge +} -result {1} +# - Enabling autopurge +test process-2.2 {enable autopurge} -body { + tcl::process autopurge true + tcl::process autopurge +} -result {1} +# - Disabling autopurge +test process-2.3 {disable autopurge} -body { + tcl::process autopurge false + tcl::process autopurge +} -result {0} -cleanup {tcl::process autopurge true} + +# Subprocess list & status +test process-3.1 {empty subprocess list} -body { + llength [tcl::process list] +} -result {0} +test process-3.2 {empty subprocess status} -body { + dict size [tcl::process status] +} -result {0} + +# Spawn subprocesses using [exec] +# - One child +test process-4.1 {exec one child} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-4.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set pid1 [exec [interpreter] $path(exit) 0 &] + set pid2 [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-4.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set pids [exec \ + [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + &] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Spawn subprocesses using [open "|"] +# - One child +test process-5.1 {exec one child} -body { + tcl::process autopurge 0 + set f [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid [pid $f] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-5.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid1 [pid $f1] + set pid2 [pid $f2] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + close $f1 + close $f2 + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-5.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set f [open "| + \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + "] + set pids [pid $f] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} + +# Async child status +test process-6.1 {async status} -setup { + signal_exit $path(test-signalfile) 0; # clean signal-file +} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] + set status1 [lindex [tcl::process status $pid] 1] + signal_exit $path(test-signalfile); # signal exit (stop sleep) + set status2 [lindex [tcl::process status -wait $pid] 1] + expr { + $status1 eq {} + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-6.2 {selective wait} -setup { + signal_exit $path(test-signalfile) 0; # clean signal-files + signal_exit $path(test-signalfile2) 0; +} -body { + tcl::process autopurge 0 + # Child 1 sleeps 1s + set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] + # Child 2 sleeps 1s + set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &] + # Initial status + set status1_1 [lindex [tcl::process status $pid1] 1] + set status1_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 1 termination + signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep) + set status2_1 [lindex [tcl::process status -wait $pid1] 1] + set status2_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 2 termination + signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep) + set status3_2 [lindex [tcl::process status -wait $pid2] 1] + set status3_1 [lindex [tcl::process status $pid1] 1] + expr { + $status1_1 eq {} + && $status1_2 eq {} + && $status2_1 eq 0 + && $status2_2 eq {} + && $status3_1 eq 0 + && $status3_2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Error codes +test process-7.1 {normal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + lindex [tcl::process status -wait $pid] 1 +} -result {0} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.2 {abnormal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.3 {child killed} -constraints {win} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) -1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +removeFile $path(exit) +removeFile $path(sleep) + +rename wait_for_file {} +rename signal_exit {} +::tcltest::cleanupTests +return diff --git a/tests/pwd.test b/tests/pwd.test index 3d4cffd..c069eef 100644 --- a/tests/pwd.test +++ b/tests/pwd.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) 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. diff --git a/tests/range.test b/tests/range.test new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/tests/range.test diff --git a/tests/reg.test b/tests/reg.test index 34edc97..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 {"::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 @@ -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" diff --git a/tests/regexp.test b/tests/regexp.test index e29cecf..16c775e 100644 --- a/tests/regexp.test +++ b/tests/regexp.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) 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. @@ -17,8 +17,22 @@ if {"::tcltest" ni [namespace children]} { } unset -nocomplain foo - +source [file join [file dirname [info script]] tcltests.tcl] testConstraint exec [llength [info commands exec]] + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc memtest script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } +} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc @@ -40,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} { @@ -180,14 +194,14 @@ test regexp-3.7 {getting substrings back from regexp} { } {1 {1 2} {1 1} {-1 -1} {2 2}} test regexp-3.8a {-indices by multi-byte utf-8} { regexp -inline -indices {(\w+)-(\w+)} \ - "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" + "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\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + "grüß-привет"] \ [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ - "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] + "grüß-привет"] } {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { @@ -338,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} { @@ -464,7 +478,7 @@ test regexp-11.4 {regsub errors} { } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -539,133 +553,133 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co removeFile junk.tcl } -result 1 -test regexp-15.1 {regexp -start} { +test regexp-15.1 {regexp -start} -body { unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x -} {1 1} -test regexp-15.2 {regexp -start} { +} -result {1 1} +test regexp-15.2 {regexp -start} -body { unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x -} {1 2} -test regexp-15.3 {regexp -start} { +} -result {1 2} +test regexp-15.3 {regexp -start} -body { unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x -} {1 2} -test regexp-15.4 {regexp -start} { +} -result {1 2} +test regexp-15.4 {regexp -start} -body { unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x -} {1 3} -test regexp-15.5 {regexp -start, over end of string} { +} -result {1 3} +test regexp-15.5 {regexp -start, over end of string} -body { unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexp-15.6 {regexp -start, loss of ^$ behavior} { +} -result {0 0} +test regexp-15.6 {regexp -start, loss of ^$ behavior} -body { list [regexp -start 2 {^$} {}] -} {0} -test regexp-15.7 {regexp -start, double option} { +} -result {0} +test regexp-15.7 {regexp -start, double option} -body { regexp -start 2 -start 0 a abc -} 1 -test regexp-15.8 {regexp -start, double option} { +} -result 1 +test regexp-15.8 {regexp -start, double option} -body { regexp -start 0 -start 2 a abc -} 0 -test regexp-15.9 {regexp -start, end relative index} { +} -result 0 +test regexp-15.9 {regexp -start, end relative index} -body { unset -nocomplain x list [regexp -start end {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexp-15.10 {regexp -start, end relative index} { +} -result {0 0} +test regexp-15.10 {regexp -start, end relative index} -body { unset -nocomplain x list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x -} {1 1 3} -test regexp-15.11 {regexp -start, over end of string} { +} -result {1 1 3} +test regexp-15.11 {regexp -start, over end of string} -body { set x NA list [regexp -start 2 {.*} ab x] $x -} {1 {}} +} -result {1 {}} -test regexp-16.1 {regsub -start} { +test regexp-16.1 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x -} {4 a1b/2c/3d/4e/5} -test regexp-16.2 {regsub -start} { +} -result {4 a1b/2c/3d/4e/5} +test regexp-16.2 {regsub -start} -body { unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x -} {0 hello} -test regexp-16.3 {regsub -start} { +} -result {0 hello} +test regexp-16.3 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x -} {0 hello} -test regexp-16.4 {regsub -start, \A behavior} { +} -result {0 hello} +test regexp-16.4 {regsub -start, \A behavior} -body { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x -} {5 /a/b/c/d/e 3 ab/c/d/e} -test regexp-16.5 {regsub -start, double option} { +} -result {5 /a/b/c/d/e 3 ab/c/d/e} +test regexp-16.5 {regsub -start, double option} -body { list [regsub -start 2 -start 0 a abc c x] $x -} {1 cbc} -test regexp-16.6 {regsub -start, double option} { +} -result {1 cbc} +test regexp-16.6 {regsub -start, double option} -body { list [regsub -start 0 -start 2 a abc c x] $x -} {0 abc} -test regexp-16.7 {regexp -start, end relative index} { +} -result {0 abc} +test regexp-16.7 {regexp -start, end relative index} -body { list [regsub -start end a aaa b x] $x -} {0 aaa} -test regexp-16.8 {regexp -start, end relative index} { +} -result {0 aaa} +test regexp-16.8 {regexp -start, end relative index} -body { list [regsub -start end-1 a aaa b x] $x -} {1 aab} -test regexp-16.9 {regsub -start and -all} { +} -result {1 aab} +test regexp-16.9 {regsub -start and -all} -body { set foo {} list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo -} {2 a|xxx|b|xx|} -test regexp-16.10 {regsub -start and -all} { +} -result {2 a|xxx|b|xx|} +test regexp-16.10 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo -} {2 a|xxx|b|xx|} -test regexp-16.11 {regsub -start and -all} { +} -result {2 a|xxx|b|xx|} +test regexp-16.11 {regsub -start and -all} -body { set foo {} list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo -} {1 axxxb|xx|} -test regexp-16.12 {regsub -start} { +} -result {1 axxxb|xx|} +test regexp-16.12 {regsub -start} -body { set foo {} list [regsub -start 4 x+ axxxbxx |&| foo] $foo -} {1 axxxb|xx|} -test regexp-16.13 {regsub -start and -all} { +} -result {1 axxxb|xx|} +test regexp-16.13 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all a+ "" & foo] $foo -} {0 {}} -test regexp-16.14 {regsub -start} { +} -result {0 {}} +test regexp-16.14 {regsub -start} -body { set foo {} list [regsub -start 1 a+ "" & foo] $foo -} {0 {}} -test regexp-16.15 {regsub -start and -all} { +} -result {0 {}} +test regexp-16.15 {regsub -start and -all} -body { set foo {} list [regsub -start 2 -all a+ "xy" & foo] $foo -} {0 xy} -test regexp-16.16 {regsub -start} { +} -result {0 xy} +test regexp-16.16 {regsub -start} -body { set foo {} list [regsub -start 2 a+ "xy" & foo] $foo -} {0 xy} -test regexp-16.17 {regsub -start and -all} { +} -result {0 xy} +test regexp-16.17 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all y+ "xy" & foo] $foo -} {1 xy} -test regexp-16.18 {regsub -start} { +} -result {1 xy} +test regexp-16.18 {regsub -start} -body { set foo {} list [regsub -start 1 y+ "xy" & foo] $foo -} {1 xy} -test regexp-16.19 {regsub -start} { +} -result {1 xy} +test regexp-16.19 {regsub -start} -body { set foo {} list [regsub -start -1 a+ "" & foo] $foo -} {0 {}} -test regexp-16.20 {regsub -start, loss of ^$ behavior} { +} -result {0 {}} +test regexp-16.20 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -start 1 {^$} {} & foo] $foo -} {0 {}} -test regexp-16.21 {regsub -start, loss of ^$ behavior} { +} -result {0 {}} +test regexp-16.21 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -start 1 {^.*$} abc & foo] $foo -} {0 abc} -test regexp-16.22 {regsub -start, loss of ^$ behavior} { +} -result {0 abc} +test regexp-16.22 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -all -start 1 {^.*$} abc & foo] $foo -} {0 abc} +} -result {0 abc} test regexp-17.1 {regexp -inline} { regexp -inline b ababa @@ -751,45 +765,45 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} { +test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d list $d [string length $d] [string bytelength $d] -} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] -test regexp-20.2 {regsub shared object shimmering with -about} { +} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] +test regexp-20.2 {regsub shared object shimmering with -about} -body { eval regexp -about abc -} {0 {}} +} -result {0 {}} -test regexp-21.1 {regsub works with empty string} { +test regexp-21.1 {regsub works with empty string} -body { regsub -- ^ {} foo -} {foo} -test regexp-21.2 {regsub works with empty string} { +} -result {foo} +test regexp-21.2 {regsub works with empty string} -body { regsub -- \$ {} foo -} {foo} -test regexp-21.3 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.3 {regsub works with empty string offset} -body { regsub -start 0 -- ^ {} foo -} {foo} -test regexp-21.4 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.4 {regsub works with empty string offset} -body { regsub -start 0 -- \$ {} foo -} {foo} -test regexp-21.5 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.5 {regsub works with empty string offset} -body { regsub -start 3 -- \$ {123} foo -} {123foo} -test regexp-21.6 {regexp works with empty string} { +} -result {123foo} +test regexp-21.6 {regexp works with empty string} -body { regexp -- ^ {} -} {1} -test regexp-21.7 {regexp works with empty string} { +} -result {1} +test regexp-21.7 {regexp works with empty string} -body { regexp -start 0 -- ^ {} -} {1} -test regexp-21.8 {regexp works with empty string offset} { +} -result {1} +test regexp-21.8 {regexp works with empty string offset} -body { regexp -start 3 -- ^ {123} -} {0} -test regexp-21.9 {regexp works with empty string offset} { +} -result {0} +test regexp-21.9 {regexp works with empty string offset} -body { regexp -start 3 -- \$ {123} -} {1} +} -result {1} test regexp-21.10 {multiple matches handle newlines} { regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n } "foo\nfoo\nfoo\n" @@ -1093,13 +1107,13 @@ test regexp-26.1 {matches start of line 1 time} { test regexp-26.2 {matches start of line(s) 2 times} { regexp -all -inline -line -- {^a+} "aab\naaa" } {aa aaa} -test regexp-26.3 {effect of -line -all and -start} { +test regexp-26.3 {effect of -line -all and -start} -body { list \ [regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \ -} {{aa aaa} aaa aaa aaa} +} -result {{aa aaa} aaa aaa aaa} # No regexp-26.4 test regexp-26.5 {match length 0, match length 1} { regexp -all -inline -line -- {^b*} "a\nb" @@ -1134,6 +1148,57 @@ test regexp-26.12 {regexp with -line option} { test regexp-26.13 {regexp without -line option} { regexp -all -inline -- {a*} "b\n" } {{} {}} + +test regexp-27.1 {regsub -command} { + regsub -command {.x.} {abcxdef} {string length} +} ab3ef +test regexp-27.2 {regsub -command} { + regsub -command {.x.} {abcxdefxghi} {string length} +} ab3efxghi +test regexp-27.3 {regsub -command} { + set x 0 + regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}} +} 1a2b3c4d5e +test regexp-27.4 {regsub -command} -body { + regsub -command {.x.} {abcxdef} error +} -returnCodes error -result cxd +test regexp-27.5 {regsub -command} { + regsub -command {(.)(.)} {abcdef} {list ,} +} {, ab a bcdef} +test regexp-27.6 {regsub -command} { + regsub -command -all {(.)(.)} {abcdef} {list ,} +} {, ab a b, cd c d, ef e f} +test regexp-27.7 {regsub -command representation smash} { + set ::s {123=456 789} + regsub -command -all {\d+} $::s {apply {n { + expr {[llength $::s] + $n} + }}} +} {125=458 791} +test regexp-27.8 {regsub -command representation smash} { + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + $n} + }}} + regsub -command -all {\d+} "123=456 789" $::t +} {131=464 797} +test regexp-27.9 {regsub -command memory leak testing} memory { + set ::s "123=456 789" + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n} + }}} + memtest { + regsub -command -all {\d+} $::s $::t + } +} 0 +test regexp-27.10 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc "def \{ghi" +} -result {unmatched open brace in list} +test regexp-27.11 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc {} +} -result {command prefix must be a list of at least one element} +test regexp-27.12 {regsub -command representation smash} { + set s {list (.+)} + regsub -command $s {list list} $s +} {(.+) {list list} list} # cleanup ::tcltest::cleanupTests diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 926d9ef..42f1b3b 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.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) 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. @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] + # Procedure to evaluate a script within a proc, to test compilation # functionality @@ -62,8 +64,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 +449,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} @@ -587,7 +589,7 @@ test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg @@ -665,54 +667,54 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} removeFile junk.tcl } -result 1 -test regexpComp-15.1 {regexp -start} { +test regexpComp-15.1 {regexp -start} -body { unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x -} {1 1} -test regexpComp-15.2 {regexp -start} { +} -result {1 1} +test regexpComp-15.2 {regexp -start} -body { unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x -} {1 2} -test regexpComp-15.3 {regexp -start} { +} -result {1 2} +test regexpComp-15.3 {regexp -start} -body { unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x -} {1 2} -test regexpComp-15.4 {regexp -start} { +} -result {1 2} +test regexpComp-15.4 {regexp -start} -body { unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x -} {1 3} -test regexpComp-15.5 {regexp -start, over end of string} { +} -result {1 3} +test regexpComp-15.5 {regexp -start, over end of string} -body { unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { +} -result {0 0} +test regexpComp-15.6 {regexp -start, loss of ^$ behavior} -body { list [regexp -start 2 {^$} {}] -} {0} +} -result {0} -test regexpComp-16.1 {regsub -start} { +test regexpComp-16.1 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x -} {4 a1b/2c/3d/4e/5} -test regexpComp-16.2 {regsub -start} { +} -result {4 a1b/2c/3d/4e/5} +test regexpComp-16.2 {regsub -start} -body { unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x -} {0 hello} -test regexpComp-16.3 {regsub -start} { +} -result {0 hello} +test regexpComp-16.3 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x -} {0 hello} -test regexpComp-16.4 {regsub -start, \A behavior} { +} -result {0 hello} +test regexpComp-16.4 {regsub -start, \A behavior} -body { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x -} {5 /a/b/c/d/e 3 ab/c/d/e} +} -result {5 /a/b/c/d/e 3 ab/c/d/e} -test regexpComp-17.1 {regexp -inline} { +test regexpComp-17.1 {regexp -inline} -body { regexp -inline b ababa -} {b} -test regexpComp-17.2 {regexp -inline} { +} -result {b} +test regexpComp-17.2 {regexp -inline} -body { regexp -inline (b) ababa -} {b b} +} -result {b b} test regexpComp-17.3 {regexp -inline -indices} { regexp -inline -indices (b) ababa } {{1 1} {1 1}} @@ -791,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} { +test regexpComp-20.1 {regsub shared object shimmering} deprecated { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz diff --git a/tests/registry.test b/tests/registry.test index 53e48fe..2f1fd8c 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -7,8 +7,8 @@ # 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 {"::tcltest" ni [namespace children]} { package require tcltest 2.5 @@ -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.7] }]} { 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.7} 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 2b975c6..eee551a 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. diff --git a/tests/rename.test b/tests/rename.test index ddda909..9b8f9a0 100644 --- a/tests/rename.test +++ b/tests/rename.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-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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 88eae99..ea84956 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -4,8 +4,8 @@ # 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] diff --git a/tests/result.test b/tests/result.test index 6e51e4e..5ae29b2 100644 --- a/tests/result.test +++ b/tests/result.test @@ -4,8 +4,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) 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Some tests require the testsaveresult command @@ -33,7 +33,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result notCalled present} +} {dynamic result presentOrFreed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -45,7 +45,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 called missing} +} {42 presentOrFreed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} @@ -109,14 +109,14 @@ test result-6.0 {Bug 1209759} -constraints testreturn -body { # Might panic if bug is not fixed. proc foo {} {testreturn} foo -} -returnCodes ok -result {} +} -result {} test result-6.1 {Bug 1209759} -constraints testreturn -body { # Might panic if bug is not fixed. proc foo {} {catch {return -level 2}; testreturn} foo } -cleanup { rename foo {} -} -returnCodes ok -result {} +} -result {} test result-6.2 {Bug 1649062} -setup { proc foo {} { if {[catch { diff --git a/tests/safe-stock.test b/tests/safe-stock.test index 0bab25d..24e90a0 100644 --- a/tests/safe-stock.test +++ b/tests/safe-stock.test @@ -1,9 +1,9 @@ # 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.6 to perform the tests. -# These files may be changed or disappear in future revisions of Tcl, -# for example package http 1.0 will be removed from Tcl 8.7. +# 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 @@ -12,8 +12,18 @@ # 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. +# - 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. @@ -27,10 +37,50 @@ 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 [list $tcl_library TCLLIB $TestsDir TESTSDIR] +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 {} @@ -39,55 +89,125 @@ proc mapList {map listIn} { } 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 unexported (and # thus unautoindexed) APIs in this test result arguments: catch {safe::interpConfigure} +testConstraint AutoSyncDefined 1 + # high level general test -test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body { +test safe-stock-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } 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 http 2}] + set v [interp eval $i {package require opt}] # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i + interp eval $i {::tcl::Lempty {a list}} set v -} -match glob -result 2.* -test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result 0.4.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } +} -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 (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]] - # an error shall occur (http is not anymore in the secure 0-level - # provided deep path) list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ - {TCLLIB */dummy/unixlike/test/path} -- {}} -test safe-stock-7.4 {tests specific path and positive search, uses http1.0} -body { +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}" +test safe-stock-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } +} -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 - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + # 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, http should be found + # this time, unlike test safe-stock-7.2, opt should be found list $token1 $token2 -- \ - [catch {interp eval $i {package require http 1}} msg] $msg -- \ - $mappA -- [safe::interpDelete $i] -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} + [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 { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ + {TCLLIB * TCLLIB/OPTDIR} -- {}} +test safe-stock-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} # 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 test 5.1} -setup { +test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup { catch {safe::interpDelete a} safe::interpCreate a } -body { @@ -95,11 +215,226 @@ test safe-stock-9.8 {test auto-loading in safe interpreters, was test 5.1} -setu } -cleanup { safe::interpDelete a } -result -1 +test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } +} -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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 with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } +} -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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*}} + +test safe-stock-18.1 {cf. safe-stock-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + # Without AutoPathSync, we need a more complete auto_path, + # because the child will use the same value. + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result 0.4.* +test safe-stock-18.2 {cf. safe-stock-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + # This will differ from the value -autoPath {} + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # 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) + list $auto1 $token1 $token2 \ + [catch {interp eval $i {package require opt}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" +test safe-stock-18.4 {cf. safe-stock-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + # This will differ from the value -autoPath {} + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # 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]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This time, unlike test safe-stock-18.2opt and the try above, opt should be found: + list $auto1 $auto2 $token1 $token2 \ + [catch {interp eval $i {package require opt}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ + {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" +test safe-stock-18.5 {cf. safe-stock-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} set ::auto_path $SaveAutoPath -unset SaveAutoPath TestsDir PathMapp +unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp rename mapList {} - +rename mapAndSortList {} # cleanup ::tcltest::cleanupTests return diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test new file mode 100644 index 0000000..41c4b78 --- /dev/null +++ b/tests/safe-zipfs.test @@ -0,0 +1,837 @@ +# 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. + + +apply [list {} { + global auto_path + global tcl_library + 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} + + testConstraint AutoSyncDefined 1 + + # 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 with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -match glob -result 1.2.3 + test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } + } -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 { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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 with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } + } -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 { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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) with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + } -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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) with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + } -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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 with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + } -body { + # For complete correspondence to safe-stock-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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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 with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + } -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + } -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; stale data case 1; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; stale data case 0; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; stale data case 3; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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, with conventional AutoPathSync; stale data case 2 (worst case); zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -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-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + # Without AutoPathSync, we need a more complete auto_path, + # because the child will use the same value. + set lib1 [info library] + set lib2 [file join $ZipMountPoint auto0] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP + } -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -match glob -result 1.2.3 + test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + } -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # 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]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i] + } -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1 {can't find package SafeTestPackage1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path $ZipMountPoint/auto0]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" + test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + } -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + # This will differ from the value -autoPath {} + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # 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]] + + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This will differ from the value -autoPath {} + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-zipfs-18.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i] + } -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } + } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3 {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" + + # cleanup + set ::auto_path $SaveAutoPath + zipfs unmount ${ZipMountPoint} + unset SaveAutoPath TestsDir ZipMountPoint PathMapp + rename mapList {} + rename mapAndSortList {} + ::tcltest::cleanupTests + return +} [namespace current]] + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe.test b/tests/safe.test index 632a959..0a888f4 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -4,19 +4,18 @@ # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # -# The package http 1.0 is convenient for testing package loading, but will soon -# be removed. -# - Tests that use http are replaced here with tests that use example packages +# 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 +# - These are tests 7.1 7.2 7.4 9.11 9.13 17.1 17.2 17.4 # - Tests 5.* test the example packages themselves before they # are used to test Safe Base interpreters. -# - Alternative tests using stock packages of Tcl 8.6 are in file +# - Alternative tests using stock packages of Tcl 8.7 are in file # safe-stock.test. # -# 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. @@ -25,6 +24,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] foreach i [interp children] { interp delete $i @@ -35,6 +36,11 @@ set ::auto_path [info library] set TestsDir [file normalize [file dirname [info script]]] set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] +proc getAutoPath {child} { + set ap1 [lrange [lindex [safe::interpConfigure $child -autoPath] 1] 0 end] + set ap2 [::safe::DetokPath $child [interp eval $child set ::auto_path]] + list $ap1 -- $ap2 +} proc mapList {map listIn} { set listOut {} foreach element $listIn { @@ -55,31 +61,74 @@ proc mapAndSortList {map listIn} { 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}]}] +testConstraint AutoSyncDefined 1 +### 1. Basic help/error messages. + 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} -test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { +} -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, Sync Mode on} -returnCodes error -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } +} -body { safe::interpCreate -help +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 -nested boolean (false) nested loading -deleteHook script () delete hook} +test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + safe::interpCreate -help +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {Usage information: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + (-help gives this help) + ?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 + -nested boolean (false) nested loading + -deleteHook script () delete hook + -autoPath list () ::auto_path for the child} 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} + +### 2. Aliases in a new "interp create" interpreter. test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] @@ -102,7 +151,10 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} + +### 3. Simple use of interpCreate, interpInit. +### Aliases in a new "interpCreate/interpInit" interpreter. test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} @@ -120,7 +172,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source} +} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { @@ -138,6 +190,8 @@ test safe-3.4 {calling safe::interpCreate on trusted interp} -setup { safe::interpDelete a } -result {} +### 4. Testing safe::interpDelete, double interpCreate. + test safe-4.1 {safe::interpDelete} -setup { catch {safe::interpDelete a} } -body { @@ -170,9 +224,9 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# 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. +### 5. Test the example files before using them to test safe interpreters. +### The old test "safe-5.1" has been moved to "safe-stock-9.8". +### A replacement test using example files is "safe-9.8". unset -nocomplain path @@ -285,7 +339,8 @@ test safe-5.6 {example modules packages, test in parent interpreter, append to p catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} -# test safe interps 'information leak' +### 6. Test safe interps 'information leak'. + proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if # there is a failure in the script. @@ -315,9 +370,16 @@ rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... -# high level general test -# Use example packages not http1.0 etc -test safe-7.1 {tests that everything works at high level} -setup { +### 7. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode off are 17.* + +test safe-7.1 {positive non-module package require, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] @@ -332,8 +394,18 @@ test safe-7.1 {tests that everything works at high level} -setup { set v } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -match glob -result 1.2.3 -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) @@ -344,12 +416,14 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { 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) + # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory) list $token1 $token2 $token3 -- \ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] } -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ 1 {can't find package SafeTestPackage1} --\ {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} @@ -384,7 +458,14 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [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 { +test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } else { + set SyncVal_TMP 1 + } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) @@ -400,10 +481,39 @@ test safe-7.4 {tests specific path and positive search} -setup { # Note that the glob match elides directories (those from the module path) # other than the first and last in the access path. } -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} +test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + tcl::tm::path add [file join $TestsDir auto0 modules] + set i [safe::interpCreate] + tcl::tm::path remove [file join $TestsDir auto0 modules] + interp eval $i { + package forget mod1::test1 + catch {namespace delete ::mod1} + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require test1}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {1 {can't find package test1} 0} + +### 8. Test source control on file name. -# test source control on file name test safe-8.1 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -439,7 +549,7 @@ test safe-8.3 {safe source control on file} -setup { safe::interpDelete $i rename safe-test-log {} unset i log -} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} +} -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} @@ -455,7 +565,7 @@ test safe-8.4 {safe source control on file} -setup { safe::interpDelete $i rename safe-test-log {} unset i log -} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} +} -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} @@ -475,7 +585,7 @@ test safe-8.5 {safe source control on file} -setup { safe::interpDelete $i rename safe-test-log {} unset i log -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] +} -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} @@ -493,7 +603,7 @@ test safe-8.6 {safe source control on file} -setup { safe::interpDelete $i rename safe-test-log {} unset i log -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] +} -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} @@ -513,7 +623,7 @@ test safe-8.7 {safe source control on file} -setup { safe::interpDelete $i rename safe-test-log {} unset i log -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] +} -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] @@ -548,6 +658,9 @@ test safe-8.10 {safe source and return} -setup { unset i } -result ok +### 9. Assorted options, including changes to option values. +### If Sync Mode is on, a corresponding test with Sync Mode off is 19.* + test safe-9.1 {safe interps' deleteHook} -setup { set i "a" catch {safe::interpDelete $i} @@ -591,7 +704,7 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { catch {rename testDelHook {}} rename safe-test-log {} unset i log res -} -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}}} +} -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} @@ -650,7 +763,12 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { {-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 { +test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -668,9 +786,17 @@ test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -706,10 +832,18 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -743,11 +877,19 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -787,11 +929,19 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -826,12 +976,20 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -862,10 +1020,18 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 { +test safe-9.20 {check module loading, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -898,6 +1064,9 @@ test safe-9.20 {check module loading} -setup { tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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\ @@ -911,7 +1080,12 @@ test safe-9.20 {check module loading} -setup { # 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 { +test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -964,6 +1138,9 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 --\ @@ -973,7 +1150,12 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st 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 { +test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1021,6 +1203,9 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 --\ @@ -1030,7 +1215,12 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st 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 { +test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1088,6 +1278,9 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 --\ @@ -1097,7 +1290,12 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st 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 { +test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1150,6 +1348,9 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } } -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 --\ @@ -1160,58 +1361,62 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st res0 res1 res2} # See comments on lsort after test safe-9.20. -catch {teststaticpkg Safepkg1 0 0} -test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { +### 10. Test options -statics -nostatics -nested -nestedloadok + +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 {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.1.1 {testing statics loading} -constraints 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 { +} -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -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 {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints 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 { +} -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -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}"} + +### 11. Safe encoding. test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -1219,14 +1424,14 @@ test safe-11.1 {testing safe encoding} -setup { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test safe-11.1a {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding foobar } -returnCodes error -cleanup { safe::interpDelete $i -} -match glob -result {bad option "foobar": must be *} +} -match glob -result {unknown or ambiguous subcommand "foobar": must be *} test safe-11.2 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1268,21 +1473,19 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { catch {interp eval $i encoding convertfrom} m o dict get $o -errorinfo -} -returnCodes ok -match glob -cleanup { +} -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data" while executing "encoding convertfrom" invoked from within -"::interp invokehidden interp* encoding convertfrom" - invoked from within "encoding convertfrom" invoked from within "interp eval $i encoding convertfrom"} @@ -1292,25 +1495,26 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { catch {interp eval $i encoding convertto} m o dict get $o -errorinfo -} -returnCodes ok -match glob -cleanup { +} -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data" while executing "encoding convertto" invoked from within -"::interp invokehidden interp* encoding convertto" - invoked from within "encoding convertto" invoked from within "interp eval $i encoding convertto"} +### 12. Safe glob. +### More tests of glob in sections 13, 16. + test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] } -body { @@ -1361,6 +1565,9 @@ test safe-12.7 {glob is restricted} -setup { safe::interpDelete $i } -result {permission denied} +### 13. More tests for Safe base glob, with patches @ Bug 2964715 +### More tests of glob in sections 12, 16. + proc buildEnvironment {filename} { upvar 1 testdir testdir testdir2 testdir2 testfile testfile set testdir [makeDirectory deletethisdir] @@ -1376,7 +1583,7 @@ proc buildEnvironment2 {filename} { 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] } -body { @@ -1513,7 +1720,8 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p rename buildEnvironment {} rename buildEnvironment2 {} -#### Test for the module path +### 14. Sanity checks on paths - module path, access path, auto_path. + test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { @@ -1525,6 +1733,122 @@ test safe-14.1 {Check that module path is the same as in the parent interpreter } -cleanup { safe::interpDelete $i } -result [::tcl::tm::path list] +test safe-14.2 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.2.1 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [info library] [info library] [info library]] +test safe-14.3 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the child + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.3.1 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the child + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] + + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [info library] [info library] [info library]] + +### 15. Safe file ensemble. test safe-15.1 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] @@ -1563,7 +1887,10 @@ test safe-15.2 {safe file ensemble does not surprise code} -setup { invoked from within "interp eval $i {file isdirectory .}"}} -### ~ should have no special meaning in paths in safe interpreters +### 16. ~ should have no special meaning in paths in safe interpreters. +### Defang it in glob. +### More tests of glob in sections 12, 13. + test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar @@ -1657,10 +1984,1576 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup safe::interpDelete $i unset user } -result {~USER} + +### 17. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode on are 7.* + +test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + # Without AutoPathSync, we need a more complete auto_path, + # because the child will use the same value. + set lib1 [info library] + set lib2 [file join $TestsDir auto0] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result 1.2.3 +test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + # This does not change the value of option -autoPath: + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # 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 $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory) + list $auto1 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ + 1 {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library \ + */dummy/unixlike/test/path \ + $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" +# (not a counterpart of safe-7.3) +test safe-17.3 {Check that default auto_path is the same as in the parent interpreter, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate] +} -body { + # This file's header sets auto_path to a single directory [info library], + # which is the one required by Safe Base to be present & first in the list. + set ap {} + foreach token [$i eval set ::auto_path] { + lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] + } + return [list $ap [lindex [::safe::interpConfigure $i -autoPath] 1]] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list $::auto_path $::auto_path] +test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + # This does not change the value of option -autoPath. + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # 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]] + + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-17.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}\ + -autoPath {}} {}" +test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + tcl::tm::path add [file join $TestsDir auto0 modules] + set i [safe::interpCreate] + tcl::tm::path remove [file join $TestsDir auto0 modules] + interp eval $i { + package forget mod1::test1 + catch {namespace delete ::mod1} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require test1}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {1 {can't find package test1} 0} + +### 18. Test tokenization of directories available to a child. + +test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {} +test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {} +test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {} +test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {} + +### 19. Assorted options, including changes to option values. +### Mostly these are changes to access path, auto_path, module path. +### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* + +test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $toksC +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}}} +test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # 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]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # 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]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $mappD -- $toksC -- $toksD +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} +test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # 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]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # 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]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $mappD -- $toksC -- $toksD +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} +test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement (1), Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # 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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # 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]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]] + # 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]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $mappD -- $toksC -- $toksD -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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*} --\ + {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:1:)}} --\ + 0 OK1 0 OK2} +test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + # To manage without path auto0, use an auto_path that is unusual for + # package discovery. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] \ + -autoPath [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]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $mappD -- $toksC -- $toksD -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:1:)} {$p(:2:)}} --\ + 0 OK1 0 OK2} +test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + # Path auto0 added (cf. safe-9.3) because it is needed for auto_path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # 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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:2:)} and {$p(:3:)}. + 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] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 -- $mappC -- $mappD -- $toksC -- $toksD +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB*} -- {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)}}} +# (no counterpart safe-9.14) +test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + # Test that although -autoPath is unchanged, the child's ::auto_path changes to + # reflect the changes in token mappings. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # 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]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:3:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 $path0 $path1 $path2 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \ + $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} {$p(:1:)} -- {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1 TESTSDIR/auto0*} --\ + {TCLLIB TESTSDIR/auto0} --\ + {TCLLIB TESTSDIR/auto0} --\ + 0 OK1 0 OK2} +# (no counterpart safe-9.15) +test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + # Test that although -autoPath is unchanged, the child's ::auto_path changes to + # reflect the changes in token mappings; and that it is based on the -autoPath + # value, not the previously restricted child ::auto_path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0]] \ + -autoPath [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 path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Add more directories. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # 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 $path0 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \ + $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} -- {$p(:1:)} {$p(:2:)} {$p(:3:)} -- {{$p(:0:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + 0 OK1 0 OK2} +# (no counterpart safe-9.16) +test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoPath preserved when -accessPath changes, ::auto_path using changed tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set tmpAutoPath $::auto_path + set ::auto_path [list $tcl_library [file join $TestsDir auto0]] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # Test that the -autoPath acquires and keeps the parent's value unless otherwise specified. + + # Inspect. + set confA [safe::interpConfigure $i] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Remove a directory. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path5 $path3 -- [lindex $toksC 0] [llength $toksC] -- \ + $toksD -- $code3 $msg3 $code4 $msg4 -- \ + $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:0:)} 2 --\ + {{$p(:0:)} {$p(:1:)}} -- 0 1.2.3 1 {can't find package SafeTestPackage2} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + 0 OK1 1 {invalid command name "HeresPackage2"}} +test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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} +# See comments on lsort after test safe-9.20. +test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + 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 + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -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. + + +### 20. safe::interpCreate with different cases of -accessPath, -autoPath. + +set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]] + +test safe-20.1 "create -accessPath NULL -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list $::auto_path -- $::auto_path] +test safe-20.2 "create -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list $::auto_path -- $::auto_path] +test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1]] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -autoPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath {} -autoPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath {} -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath {} -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} + +### 21. safe::interpConfigure with different cases of -accessPath, -autoPath. + +test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -deleteHook {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list $::auto_path -- $::auto_path] +test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 1 1] -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 + } else { + error {This test is meaningful only if the command ::safe::setSyncMode is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setSyncMode $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} # cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp +rename getAutoPath {} unset -nocomplain path rename mapList {} rename mapAndSortList {} diff --git a/tests/scan.test b/tests/scan.test index cd2ba63..98ec314 100644 --- a/tests/scan.test +++ b/tests/scan.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. @@ -19,11 +19,8 @@ if {"::tcltest" ni [namespace children]} { # procedure that returns the range of integers proc int_range {} { - for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { - set MIN_INT [expr { $MIN_INT << 1 }] - } - set MIN_INT [expr {int($MIN_INT)}] - set MAX_INT [expr { ~ $MIN_INT }] + set MAX_INT [expr {[format %u -2]/2}] + set MIN_INT [expr { ~ $MAX_INT }] return [list $MIN_INT $MAX_INT] } @@ -35,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) @@ -47,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) @@ -69,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 @@ -85,8 +82,7 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x @@ -557,8 +553,13 @@ test scan-5.19 {bigint scanning invalid} -setup { set a {}; } -body { list [scan "207698809136909011942886895" \ - %llu a] $a -} -returnCodes 1 -result {unsigned bignum scans are invalid} + %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 {} @@ -604,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.9 {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 {} @@ -633,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 3235a1f..6aa7ccb 100644 --- a/tests/security.test +++ b/tests/security.test @@ -6,8 +6,8 @@ # 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]} { diff --git a/tests/set-old.test b/tests/set-old.test index 68e0497..3289ae8 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -6,9 +6,9 @@ # 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. @@ -169,7 +169,7 @@ test set-old-5.4 {errors in reading variables} { test set-old-6.1 {creating array during write} { catch {unset a} - trace var a rwu ignore + trace add var a {read write unset} ignore list [catch {set a(14) 186} msg] $msg [array names a] } {0 186 14} test set-old-6.2 {errors in writing variables} { @@ -340,7 +340,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -407,7 +407,7 @@ test set-old-8.18 {array command, get option} { test set-old-8.19 {array command, get option (unset variable)} { catch {unset a} set a(x) 3 - trace var a(y) w ignore + trace add var a(y) write ignore array get a } {x 3} test set-old-8.20 {array command, get option, with pattern} { @@ -445,13 +445,13 @@ test set-old-8.24 {array command, names option} { test set-old-8.25 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore + trace add var a(xxx) write ignore list [catch {lsort [array names a]} msg] $msg } {0 {22 33}} test set-old-8.26 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore + trace add var a(xxx) write ignore set a(xxx) value list [catch {lsort [array names a]} msg] $msg } {0 {22 33 xxx}} @@ -579,7 +579,7 @@ test set-old-8.43 {array command, size option} { test set-old-8.44 {array command, size option} { catch {unset a} set a(22) 3; - trace var a(33) rwu ignore + trace add var a(33) {read write unset} ignore list [catch {array size a} msg] $msg } {0 1} test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -700,7 +700,7 @@ test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array d a s-3-a; array start a] + [array done a s-2-a; array do a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} @@ -786,7 +786,7 @@ test set-old-9.10 {array enumeration: searches automatically stopped} { set a(a) 1 set x [array startsearch a] set y [array startsearch a] - trace var a(b) r {} + trace add var a(b) read {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} @@ -795,14 +795,14 @@ test set-old-9.11 {array enumeration: searches automatically stopped} { set a(a) 1 set x [array startsearch a] set y [array startsearch a] - trace var a(a) r {} + trace add var a(a) read {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.12 {array enumeration with traced undefined elements} { catch {unset a} set a(a) 1 - trace var a(b) r {} + trace add var a(b) read {} set x [array startsearch a] lsort [list [array next a $x] [array next a $x]] } {{} a} diff --git a/tests/set.test b/tests/set.test index 303c2d7..3f099a3 100644 --- a/tests/set.test +++ b/tests/set.test @@ -4,8 +4,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) 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -263,7 +263,7 @@ test set-2.4 {set command: runtime error, readonly variable} -setup { } -body { proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + trace add var x write readonly list [catch {set x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing @@ -521,7 +521,7 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { set z set proc readonly args {error "variable is read-only"} $z x 123 - trace var x w readonly + trace add var x write readonly list [catch {$z x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing diff --git a/tests/socket.test b/tests/socket.test index 7251bfa..82e908a 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. @@ -66,16 +66,21 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +::tcltest::loadTestedCommands # A bad interaction between socket creation, macOS, and unattended CI # environments make this whole file impractical to run; too many weird hangs. if {[info exists ::env(MAC_CI)]} { return } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] +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. @@ -96,6 +101,14 @@ proc randport {} { return $port } +# Check if testsocket testflags is available +testConstraint testsocket_testflags [expr {![catch { + set h [socket -async localhost [randport]] + testsocket testflags $h 0 + close $h + }]}] + + # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes # up to 200ms for a packet sent to localhost to arrive. We're measuring this @@ -295,13 +308,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} @@ -310,19 +323,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz -} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} +} -returnCodes error -result {bad option "-froboz": must be -async, -backlog, -myaddr, -myport, -reuseaddr, -reuseport, or -server} test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} @@ -332,6 +345,24 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} +test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr yes 4242 +} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers} +test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr no 4242 +} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers} +test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr +} -returnCodes error -result {no argument given for -reuseaddr option} +test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport yes 4242 +} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers} +test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport no 4242 +} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers} +test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport +} -returnCodes error -result {no argument given for -reuseport option} set path(script) [makeFile {} script] @@ -709,7 +740,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 { @@ -1040,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 20 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" @@ -1518,7 +1549,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 { @@ -1937,522 +1968,575 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0.0 {[socket -async] when server only listens on IPv4} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] -} -constraints {socket supported_inet localhost_v4} -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x -} -cleanup { - catch {after cancel $after} - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result ok -test socket-14.0.1 {[socket -async] when server only listens on IPv6} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] -} -constraints {socket supported_inet6 localhost_v6} -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x -} -cleanup { - catch {after cancel $after} - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result ok -test socket-14.1 {[socket -async] fileevent while still connecting} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - lappend x ok - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" -} -constraints socket -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x; # we only want to see both events, the order doesn't matter -} -cleanup { - catch {after cancel $after} - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result {{} ok} -test socket-14.2 {[socket -async] fileevent connection refused} -setup { - set after [after $latency set x timeout] -} -body { - set client [socket -async localhost [randport]] - fileevent $client writable {set x ok} - vwait x - lappend x [fconfigure $client -error] -} -constraints socket -cleanup { - catch {after cancel $after} - catch {close $client} - unset -nocomplain x after client -} -result {ok {connection refused}} -test socket-14.3 {[socket -async] when server only listens on IPv6} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] -} -constraints {socket supported_inet6 localhost_v6} -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x -} -cleanup { - catch {after cancel $after} - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result ok -test socket-14.4 {[socket -async] and both, readdable and writable fileevents} -setup { - proc accept {s a p} { - puts $s bye - close $s - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" -} -constraints socket -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - fileevent $client readable {lappend x [gets $client]} - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x -} -cleanup { - catch {after cancel $after} - catch {close $client} - catch {close $server} - unset -nocomplain x -} -result {{} bye} +test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.1 {[socket -async] fileevent while still connecting} \ + -constraints {socket} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + lappend x ok + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x; # we only want to see both events, the order doesn't matter + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result {{} ok} +test socket-14.2 {[socket -async] fileevent connection refused} \ + -constraints {socket} \ + -body { + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + set after [after $latency {set x timeout}] + vwait x + after cancel $after + lappend x [fconfigure $client -error] + } -cleanup { + after cancel $after + close $client + unset x after client + } -result {ok {connection refused}} +test socket-14.3 {[socket -async] when server only listens on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ + -constraints {socket} \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + fileevent $client readable {lappend x [gets $client]} + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x + } -cleanup { + after cancel $after + close $client + close $server + unset x + } -result {{} bye} # FIXME: we should also have an IPv6 counterpart of this -test socket-14.5 {[socket -async] which fails before any connect() can be made} -body { - # address from rfc5737 - socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] -} -constraints {socket supported_inet notOSX} -returnCodes 1 \ +test socket-14.5 {[socket -async] which fails before any connect() can be made} \ + -constraints {socket supported_inet notWine} \ + -body { + # address from rfc5737 + socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] + } \ + -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} -test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" -} -constraints {socket supported_inet localhost_v4} -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x -} -cleanup { - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result {ok bye} -test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" -} -constraints {socket supported_inet6 localhost_v6} -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x -} -cleanup { - catch {close $server} - catch {close $client} - unset -nocomplain x -} -result {ok bye} -test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet localhost_v4 notOSX} -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok {}} -test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok {}} -test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} -setup { - set sock [socket -server error 0] - set unusedPort [lindex [fconfigure $sock -sockname] 2] - close $sock -} -body { - set sock [socket -async localhost $unusedPort] - catch {gets $sock} x - list $x [fconfigure $sock -error] [fconfigure $sock -error] -} -constraints {socket notOSX} -cleanup { - catch {close $sock} -} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet localhost_v4} -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {ok} -test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet6 localhost_v6} -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {ok} -test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - list $x [fconfigure $sock -error] [fconfigure $sock -error] -} -constraints socket -cleanup { - catch {close $sock} -} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} -setup { - makeFile { - fileevent stdin readable exit - after 10000 exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet localhost_v4 notOSX} -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok} -test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} -setup { - makeFile { - fileevent stdin readable exit - after 10000 exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] -} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] -} -cleanup { - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok} -test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - set after [after $latency set x timeout] -} -constraints {socket supported_inet localhost_v4} -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] -} -cleanup { - after cancel $after - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok} -test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - set after [after $latency set x timeout] -} -constraints {socket supported_inet6 localhost_v6} -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] -} -cleanup { - after cancel $after - catch {close $fd} - catch {close $sock} - removeFile script -} -result {{} ok} -test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} -setup { - set after [after $latency set x timeout] -} -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - puts $sock ok - fileevent $sock writable {set x 1} - vwait x - close $sock -} -constraints socket -cleanup { - after cancel $after - catch {close $sock} - unset -nocomplain x -} -result {socket is not connected} -returnCodes 1 -test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} -setup { - set after [after $latency set x timeout] -} -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $sock writable {set x 1} - vwait x - close $sock -} -constraints {socket nonPortable} -cleanup { - after cancel $timeout - catch {close $sock} - unset -nocomplain x -} -result {socket is not connected} -returnCodes 1 -test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} -body { - set s [socket -async localhost [randport]] - for {set i 0} {$i < 50} {incr i} { - set x [fconfigure $s -error] - if {$x != ""} break - after 200 - } - set x -} -constraints socket -cleanup { - catch {close $s} - unset -nocomplain x s -} -result {connection refused} -test socket-14.13 {testing writable event when quick failure} -body { +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ + -constraints {socket notWinCI} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + unset x + } -result {transport endpoint is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ + -constraints {socket testsocket_testflags} \ + -body { + set sock [socket -async localhost [randport]] + # Set the socket in async test mode. + # The async connect will not be continued on the following fconfigure + # and puts/flush. Thus, the connect will fail after them. + testsocket testflags $sock 1 + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + testsocket testflags $sock 0 + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + catch {unset x} + } -result {transport endpoint is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ + -constraints {socket} \ + -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x + } -cleanup { + close $s + unset x s + } -result {connection refused} + +test socket-14.13 {testing writable event when quick failure} \ + -constraints {socket win supported_inet notWine} \ + -body { # Test for bug 336441ed59 where a quick background fail was ignored - # + # Test only for windows as socket -async 255.255.255.255 fails # directly on Unix - # + # The following connect should fail very quickly - set a1 [after $latency {set x timeout}] + set a1 [after 2000 {set x timeout}] set s [socket -async 255.255.255.255 43434] fileevent $s writable {set x writable} vwait x set x -} -constraints {socket win supported_inet} -cleanup { +} -cleanup { catch {close $s} after cancel $a1 } -result writable -test socket-14.14 {testing fileevent readable on failed async socket connect} -body { + +test socket-14.14 {testing fileevent readable on failed async socket connect} \ + -constraints {socket} -body { # Test for bug 581937ab1e - set a1 [after $latency {set x timeout}] + + set a1 [after 5000 {set x timeout}] # This connect should fail set s [socket -async localhost [randport]] fileevent $s readable {set x readable} vwait x set x -} -constraints socket -cleanup { +} -cleanup { catch {close $s} after cancel $a1 } -result readable -test socket-14.15 {blocking read on async socket should not trigger event handlers} -setup { - set subprocess [open "|[list [interpreter]]" r+] - fconfigure $subprocess -blocking 0 -buffering none -} -constraints socket -body { - puts $subprocess { - set s [socket -async localhost [randport]] - set x ok - fileevent $s writable {set x fail} - catch {read $s} + +test socket-14.15 {blocking read on async socket should not trigger event handlers} \ + -constraints socket -body { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} close $s - puts $x - exit - } - set after [after $latency set x timeout] - fileevent $subprocess readable [list gets $subprocess x] - vwait x - return $x -} -cleanup { - catch {after cancel $after} - if {![testConstraint win]} { - catch {exec kill [pid $subprocess]} - } - catch {close $subprocess} - unset -nocomplain x -} -result ok + set x + } -result ok + # v4 and v6 is required to prevent that the async connect does not terminate # before the fconfigure command. There is always an additional ip to try. -test socket-14.16 {empty -peername while [socket -async] connecting} -body { - set client [socket -async localhost [randport]] - fconfigure $client -peername -} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { - catch {close $client} -} -result {} +test socket-14.16 {empty -peername while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername + } -cleanup { + catch {close $client} + } -result {} + # v4 and v6 is required to prevent that the async connect does not terminate # before the fconfigure command. There is always an additional ip to try. -test socket-14.17 {empty -sockname while [socket -async] connecting} -body { - set client [socket -async localhost [randport]] - fconfigure $client -sockname -} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { - catch {close $client} -} -result {} +test socket-14.17 {empty -sockname while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname + } -cleanup { + catch {close $client} + } -result {} + # test for bug c6ed4acfd8: running async socket connect with other connect # established will block tcl as it goes in an infinite loop in vwait -test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} -body { - proc accept {channel address port} {} - set port [randport] - set ssock [socket -server accept $port] - set csock1 [socket -async localhost [randport]] - set csock2 [socket localhost $port] - after 1000 {set done ok} - vwait done -} -constraints {socket notOSX} -cleanup { - catch {close $ssock} - catch {close $csock1} - catch {close $csock2} -} -result {} +test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \ + -constraints {socket} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock [socket -server accept $port] + set csock1 [socket -async localhost [randport]] + set csock2 [socket localhost $port] + after 1000 {set done ok} + vwait done +} -cleanup { + catch {close $ssock} + catch {close $csock1} + catch {close $csock2} + } -result {} + +test socket-14.19 {tip 456 -- introduce the -reuseport option} \ + -constraints {socket notWine} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock1 [socket -server accept -reuseport yes $port] + set ssock2 [socket -server accept -reuseport yes $port] + return ok +} -cleanup { + catch {close $ssock1} + catch {close $ssock2} + } -result ok set num 0 @@ -2464,7 +2548,8 @@ set resulterr { } foreach {servip sc} $x { foreach {cliip cc} $x { - set constraints [list socket $sc $cc] + set constraints socket + lappend constraints $sc $cc set result $resulterr switch -- [lsort -unique [list $servip $cliip]] { localhost - 127.0.0.1 - ::1 { @@ -2481,16 +2566,17 @@ foreach {servip sc} $x { } } } - test socket-15.1.$num "Connect to $servip from $cliip" -setup { - set server [socket -server accept -myaddr $servip 0] - proc accept {s h p} { close $s } - set port [lindex [fconfigure $server -sockname] 2] - } -constraints $constraints -body { - set s [socket $cliip $port] - } -cleanup { - close $server - catch {close $s} - } {*}$result + test socket-15.1.$num "Connect to $servip from $cliip" \ + -constraints $constraints -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result incr num } } diff --git a/tests/source.test b/tests/source.test index f2a2858..f5f9f0f 100644 --- a/tests/source.test +++ b/tests/source.test @@ -4,16 +4,16 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } @@ -103,16 +103,15 @@ test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { 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 @@ -200,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 @@ -209,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 @@ -223,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 @@ -234,19 +233,19 @@ 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 unicode - puts $f "set symbol(square-root) \u221A; set x correct" + fconfigure $f -encoding utf-16 + puts $f "set symbol(square-root) √; set x correct" close $f } -body { set x unset - source -encoding unicode $sourcefile + source -encoding utf-16 $sourcefile set x } -cleanup { removeFile source.file @@ -267,28 +266,28 @@ 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 iso8859-1 $sourcefile - \u20ac + € } -cleanup { removeFile source.file -} -returnCodes error -result "invalid command name \"\u20ac\"" +} -returnCodes error -result {invalid command name "€"} test source-8.1 {source and coroutine/yield} -setup { set sourcefile [makeFile {} source.file] diff --git a/tests/split.test b/tests/split.test index efd4323..a34c49d 100644 --- a/tests/split.test +++ b/tests/split.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-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. @@ -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,8 +71,11 @@ test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} test split-1.15 {basic split commands} -body { - split "a\U01f4a9b" {} -} -result "a \U01f4a9 b" + split "a💩b" {} +} -result "a 💩 b" +test split-1.16 {basic split commands} -body { + split "a💩b" 💩 +} -result "a b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode diff --git a/tests/stack.test b/tests/stack.test index 77cb69f..461e8d3 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -4,7 +4,7 @@ # 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. diff --git a/tests/string.test b/tests/string.test index f2b8bcc..ade673e 100644 --- a/tests/string.test +++ b/tests/string.test @@ -4,10 +4,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-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2001 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. @@ -18,18 +18,47 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] + + +# Helper commands to test various optimizations, code paths, and special cases. +proc makeByteArray {s} {binary format a* $s} +proc makeUnicode {s} {lindex [regexp -inline .* $s] 0} +proc makeList {args} {return $args} +proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s} # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint testindexobj [expr {[info commands testindexobj] != {}}] -testConstraint testevalex [expr {[info commands testevalex] != {}}] +testConstraint testobj [expr {[info commands testobj] ne {}}] +testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] +testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} foreach noComp {0 1} { @@ -48,10 +77,19 @@ if {$noComp} { test string-1.1.$noComp {error conditions} -body { list [catch {run {string gorp a b}} msg] $msg -} -result {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} +test stringComp-1.3.$noComp {error condition - undefined method during compile} { + # We don't want this to complain about 'never' because it may never + # be called, or string may get redefined. This must compile OK. + proc foo {str i} { + if {"yes" == "no"} { string never called but complains here } + string index $str $i + } + foo abc 0 +} a test string-2.1.$noComp {string compare, not enough args} { list [catch {run {string compare a}} msg] $msg @@ -84,10 +122,19 @@ 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 Ü Ü} +} 0 +test string-2.11.2.$noComp {string compare, unicode} { + run {string compare Ü ü} +} -1 +test string-2.11.3.$noComp {string compare, unicode} { + run {string compare ÜÜÜüü ÜÜÜÜÜ} +} 1 test string-2.12.$noComp {string compare, high bit} { - # This test will fail if the underlying comparison + # This test fails 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" "@"} @@ -98,12 +145,21 @@ test string-2.12.$noComp {string compare, high bit} { test string-2.13.$noComp {string compare -nocase} { run {string compare -nocase abcde abdef} } -1 +test string-2.13.1.$noComp {string compare -nocase} { + run {string compare -nocase abcde Abdef} +} -1 test string-2.14.$noComp {string compare -nocase} { run {string compare -nocase abcde ABCDE} } 0 test string-2.15.$noComp {string compare -nocase} { run {string compare -nocase abcde abcde} } 0 +test string-2.15.1.$noComp {string compare -nocase} { + run {string compare -nocase Ü Ü} +} 0 +test string-2.15.2.$noComp {string compare -nocase} { + run {string compare -nocase ÜÜÜüü ÜÜÜÜÜ} +} 0 test string-2.16.$noComp {string compare -nocase with length} { run {string compare -length 2 -nocase abcde Abxyz} } 0 @@ -119,7 +175,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 @@ -142,10 +198,10 @@ test string-2.26.$noComp {string compare -nocase, null strings} { test string-2.27.$noComp {string compare -nocase, null strings} { run {string compare -nocase foo ""} } 1 -test string-2.28.$noComp {string compare with length, unequal strings} { +test string-2.28.$noComp {string compare with length, unequal strings, partial first string} { run {string compare -length 2 abc abde} } 0 -test string-2.29.$noComp {string compare with length, unequal strings} { +test string-2.29.$noComp {string compare with length, unequal strings 2, full first string} { run {string compare -length 2 ab abde} } 0 test string-2.30.$noComp {string compare with NUL character vs. other ASCII} { @@ -178,13 +234,13 @@ test string-3.1.$noComp {string equal} { run {string equal abcde abdef} } 0 test string-3.2.$noComp {string equal} { - run {string eq abcde ABCDE} + run {string e abcde ABCDE} } 0 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} @@ -198,6 +254,119 @@ 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, not enough args} { + list [catch {run {string equal a}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.10.$noComp {string equal, bad args} { + list [catch {run {string equal a b c}} msg] $msg +} {1 {bad option "a": must be -nocase or -length}} +test string-3.11.$noComp {string equal, bad args} { + list [catch {run {string equal -length -nocase str1 str2}} msg] $msg +} {1 {expected integer but got "-nocase"}} +test string-3.12.$noComp {string equal, too many args} { + list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.13.$noComp {string equal with length unspecified} { + list [catch {run {string equal -length 10 10}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.14.$noComp {string equal with length} { + run {string equal -length 2 abcde abxyz} +} 1 +test string-3.15.$noComp {string equal with special index} { + list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} + +test string-3.16.$noComp {string equal, unicode} { + run {string equal ab牦 ab牧} +} 0 +test string-3.17.$noComp {string equal, unicode} { + run {string equal Ü Ü} +} 1 +test string-3.18.$noComp {string equal, unicode} { + run {string equal Ü ü} +} 0 +test string-3.19.$noComp {string equal, unicode} { + run {string equal ÜÜÜüü ÜÜÜÜÜ} +} 0 +test string-3.20.$noComp {string equal, high bit} { + # This test fails 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" "@"} + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. +} 0 +test string-3.21.$noComp {string equal -nocase} { + run {string equal -nocase abcde Abdef} +} 0 +test string-3.22.$noComp {string equal, -nocase unicode} { + run {string equal -nocase Ü Ü} +} 1 +test string-3.23.$noComp {string equal, -nocase unicode} { + run {string equal -nocase ÜÜÜüü ÜÜÜÜÜ} +} 1 +test string-3.24.$noComp {string equal -nocase with length} { + run {string equal -length 2 -nocase abcde Abxyz} +} 1 +test string-3.25.$noComp {string equal -nocase with length} { + run {string equal -nocase -length 3 abcde Abxyz} +} 0 +test string-3.26.$noComp {string equal -nocase with length <= 0} { + run {string equal -nocase -length -1 abcde AbCdEf} +} 0 +test string-3.27.$noComp {string equal -nocase with excessive length} { + run {string equal -nocase -length 50 AbCdEf abcde} +} 0 +test string-3.28.$noComp {string equal -len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + run {string equal -len 5 ÜÜÜ ÜÜü} +} 0 +test string-3.29.$noComp {string equal -nocase with special index} { + list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} +test string-3.30.$noComp {string equal, null strings} { + run {string equal "" ""} +} 1 +test string-3.31.$noComp {string equal, null strings} { + run {string equal "" foo} +} 0 +test string-3.32.$noComp {string equal, null strings} { + run {string equal foo ""} +} 0 +test string-3.33.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" ""} +} 1 +test string-3.34.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" foo} +} 0 +test string-3.35.$noComp {string equal -nocase, null strings} { + run {string equal -nocase foo ""} +} 0 +test string-3.36.$noComp {string equal with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + run {string equal \x00 \x01} +} 0 +test string-3.37.$noComp {string equal, high bit} { + run {string equal "a\x80" "a@"} +} 0 +test string-3.38.$noComp {string equal, high bit} { + run {string equal "a\x00" "a\x01"} +} 0 +test string-3.39.$noComp {string equal, high bit} { + run {string equal "a\x00\x00" "a\x00\x01"} +} 0 +test string-3.40.$noComp {string equal, binary equal} { + run {string equal [binary format a100 0] [binary format a100 0]} +} 1 +test string-3.41.$noComp {string equal, binary neq} { + run {string equal [binary format a100a 0 1] [binary format a100a 0 0]} +} 0 +test string-3.42.$noComp {string equal, binary neq inequal length} { + run {string equal [binary format a20a 0 1] [binary format a100a 0 0]} +} 0 test string-4.1.$noComp {string first, not enough args} { list [catch {run {string first a}} msg] $msg @@ -224,19 +393,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} @@ -245,12 +414,19 @@ 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 { + set s hello + regexp ll $s m + # Representation checks are canaries + run {list [representationpoke $s] [representationpoke $m] \ + [string first $m $s]} +} -match glob -result {{*string 1} {*string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} -} -result 0 +} -result -1 test string-4.18.$noComp {string first, corner case} -body { run {string first a aaa -1} } -result 0 @@ -259,7 +435,7 @@ test string-4.19.$noComp {string first, corner case} -body { } -result 0 test string-4.20.$noComp {string last, corner case} -body { run {string last a aaa 4294967295} -} -result -1 +} -result 2 test string-4.21.$noComp {string last, corner case} -body { run {string last a aaa -1} } -result -1 @@ -277,7 +453,7 @@ test string-5.3.$noComp {string index} { run {string index abcde 0} } a test string-5.4.$noComp {string index} { - run {string in abcde 4} + run {string ind abcde 4} } e test string-5.5.$noComp {string index} { run {string index abcde 5} @@ -295,13 +471,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} @@ -332,18 +508,13 @@ 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 utf16 -body { + run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} +} -result [list \U100000 {} b] test string-5.22.$noComp {string index} -constraints testbytestring -body { run {list [scan [string index [testbytestring \xFF] 0] %c var] $var} } -result {1 255} -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, not enough args} { list [catch {run {string is}} msg] $msg @@ -359,10 +530,10 @@ test string-6.4.$noComp {string is, too many args} { } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} test string-6.5.$noComp {string is, class check} { list [catch {run {string is bogus str}} msg] $msg -} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}} test string-6.6.$noComp {string is, ambiguous class} { list [catch {run {string is al str}} msg] $msg -} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}} test string-6.7.$noComp {string is alpha, all ok} { run {string is alpha -strict -failindex var abc} } 1 @@ -385,7 +556,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 @@ -393,7 +564,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} @@ -417,7 +588,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 @@ -459,7 +630,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} { @@ -518,9 +689,9 @@ test string-6.53.$noComp {string is integer, true with whitespace} { 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, false on overflow} { - list [run {string is integer -fail var +[largest_int]0}] $var -} {0 -1} +test string-6.55.$noComp {string is integer, no overflow possible} { + run {string is integer +9223372036854775808} +} 1 test string-6.56.$noComp {string is integer, false} { list [run {string is integer -fail var [expr {double(1)}]}] $var } {0 1} @@ -540,7 +711,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 @@ -549,7 +720,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"} @@ -587,7 +758,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 @@ -596,13 +767,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 @@ -651,22 +822,22 @@ test string-6.91.$noComp {string is double, bad doubles} { } return $result } {1 1 0 0 0 1 0 0} -test string-6.92.$noComp {string is integer, 32-bit overflow} { +test string-6.92.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [run {string is integer -failindex var $x}] $var -} {0 -1} -test string-6.93.$noComp {string is integer, 32-bit overflow} { + set x 0x10000000000000000 + run {string is integer $x} +} 1 +test string-6.93.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 + set x 0x10000000000000000 append x "" - list [run {string is integer -failindex var $x}] $var -} {0 -1} -test string-6.94.$noComp {string is integer, 32-bit overflow} { + run {string is integer $x} +} 1 +test string-6.94.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [run {string is integer -failindex var [expr {$x}]}] $var -} {0 -1} + set x 0x10000000000000000 + run {string is integer [expr {$x}]} +} 1 test string-6.95.$noComp {string is wideinteger, true} { run {string is wideinteger +1234567890} } 1 @@ -689,7 +860,7 @@ 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 @@ -795,24 +966,44 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} { test string-6.131.$noComp {string is entier, false on bad hex} { list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} +test string-6.132.$noComp {string is unicode} { + run {string is unicode \U10FFFD\uD7FF\uE000\uFDCF\uFDF0} +} 1 +test string-6.133.$noComp {string is unicode, upper surrogate} { + run {string is unicode \uD800} +} 0 +test string-6.134.$noComp {string is unicode, lower surrogate} { + run {string is unicode \uDFFF} +} 0 +test string-6.135.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFFFE} +} 0 +test string-6.136.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFFFF} +} 0 +test string-6.137.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFDD0} +} 0 +test string-6.138.$noComp {string is unicode, noncharacter} { + run {string is unicode \uFDEF} +} 0 test string-6.139.$noComp {string is integer, bug [76ad7aeba3]} { run {string is integer 18446744073709551615} -} 0 +} 1 test string-6.140.$noComp {string is integer, bug [76ad7aeba3]} { run {string is integer -18446744073709551615} -} 0 +} 1 -catch {rename largest_int {}} 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 ?startIndex?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.2.$noComp {string last, bad args} { list [catch {run {string last a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-7.3.$noComp {string last, too many args} { list [catch {run {string last a b c d}} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.4.$noComp {string last} { run {string la xxx xxxx123xx345x678} } 1 @@ -823,22 +1014,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 @@ -849,22 +1040,22 @@ 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} { +test string-8.1.$noComp {string bytelength} deprecated { list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} { +test string-8.2.$noComp {string bytelength} deprecated { list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} { +test string-8.3.$noComp {string bytelength} deprecated { run {string bytelength "\xC7"} } 2 -test string-8.4.$noComp {string bytelength} { +test string-8.4.$noComp {string bytelength} deprecated { run {string b ""} } 0 @@ -881,7 +1072,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]} @@ -901,13 +1092,13 @@ test string-10.3.$noComp {string map, too many args} { } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} test string-10.4.$noComp {string map} { run {string map {a b} abba} -} {bbbb} +} bbbb test string-10.5.$noComp {string map} { run {string map {a b} a} -} {b} +} b test string-10.6.$noComp {string map -nocase} { run {string map -nocase {a b} Abba} -} {bbbb} +} bbbb test string-10.7.$noComp {string map} { run {string map {abc 321 ab * a A} aabcabaababcab} } {A321*A*321*} @@ -922,25 +1113,25 @@ test string-10.10.$noComp {string map} { } {1 {char map list unbalanced}} test string-10.11.$noComp {string map, nulls} { run {string map {\x00 NULL blah \x00nix} {qwerty}} -} {qwerty} +} qwerty test string-10.12.$noComp {string map, unicode} { - run {string map [list \374 ue UE \334] "a\374ueUE\x00EU"} -} aueue\334\x00EU + 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\x00EU"} -} aue\334\334\x00EU + 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 test string-10.15.$noComp {string map, one pair case} { run {string map -nocase {abc 32} aAbCaBaAbAbcAb} -} {a32aBaAb32Ab} +} a32aBaAb32Ab test string-10.16.$noComp {string map, one pair case} { run {string map -nocase {ab 4321} aAbCaBaAbAbcAb} -} {a4321C4321a43214321c4321} +} a4321C4321a43214321c4321 test string-10.17.$noComp {string map, one pair case} { run {string map {Ab 4321} aAbCaBaAbAbcAb} -} {a4321CaBa43214321c4321} +} a4321CaBa43214321c4321 test string-10.18.$noComp {string map, empty argument} { run {string map -nocase {{} abc} foo} } foo @@ -1132,7 +1323,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} @@ -1245,6 +1436,11 @@ test string-11.55.$noComp {string match, invalid binary optimization} { [format string] match \u0141 [binary format c 65] } 0 +test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} test string-12.1.$noComp {string range} { list [catch {run {string range}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} @@ -1294,11 +1490,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}] @@ -1332,6 +1528,20 @@ test string-12.22.$noComp {string range, shimmering binary/index} { 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 @@ -1367,15 +1577,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 @@ -1433,6 +1643,65 @@ test string-14.18.$noComp {string replace} { test string-14.19.$noComp {string replace} { run {string replace {} -1 0 A} } A +test string-14.20.$noComp {string replace} { + run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ + [makeByteArray NEW]} +} {abcdeNEWop} +test 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 string-14.23.$noComp {string replace \xC0 \x80} testbytestring { + run {string length [string replace [testbytestring \xC0]? 1 end [testbytestring \x80]]} +} 2 +test string-14.24.$noComp {string replace \xC0 \x80} testbytestring { + run {string length [string replace ?[testbytestring \x80] 0 end-1 [testbytestring \xC0]]} +} 2 + + +test stringComp-14.21.$noComp {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.22.$noComp {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} +test stringComp-14.23.$noComp {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 +test stringComp-14.24.$noComp {Bug 1af8de570511} { + apply {{x y} { + # Generate an unshared string value + set val "" + for { set i 0 } { $i < $x } { incr i } { + set val [format "0%s" $val] + } + string replace $val[unset val] 1 1 $y + }} 4 x +} 0x00 +test stringComp-14.25.$noComp {} { + string length [string replace [string repeat a\xFE 2] 3 end {}] +} 3 +test stringComp-14.26.$noComp {} { + run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e} +} aed test string-15.1.$noComp {string tolower not enough args} { list [catch {run {string tolower}} msg] $msg @@ -1526,6 +1795,10 @@ 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]} utf16 { + run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \ + [string totitle a\U118c0c 3 3]} +} [list a\U118a0c a\U118c0C a\U118c0C] test string-18.1.$noComp {string trim} { list [catch {run {string trim}} msg] $msg @@ -1579,7 +1852,7 @@ test string-20.1.$noComp {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2.$noComp {string trimright errors} -body { list [catch {run {string trimg a}} msg] $msg -} -result {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1613,11 +1886,11 @@ test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is lappend result [string map $m $b] lappend result [string map $m [run {string trimright $b x}]] lappend result [string map $m [run {string trimright $b \xE8}]] - lappend result [string map $m [run {string trimright $b [bytestring \xE8]}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]] lappend result [string map $m [run {string trimright $b \xA0}]] - lappend result [string map $m [run {string trimright $b [bytestring \xA0]}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]] lappend result [string map $m [run {string trimright $b \xE8\xA0}]] - lappend result [string map $m [run {string trimright $b [bytestring \xE8\xA0]}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]] lappend result [string map $m [run {string trimright $b \x00}]] } [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] @@ -1663,6 +1936,12 @@ test string-21.13.$noComp {string wordend, unicode} -body { test string-21.14.$noComp {string wordend, unicode} -body { run {string wordend "\uC700\uC700 abc" 8} } -result 6 +test string-21.15.$noComp {string wordend, unicode} -body { + run {string wordend "\U1D7CA\U1D7CA abc" 0} +} -result 2 +test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body { + run {string wordend "\U1D7CA\U1D7CA abc" 10} +} -result 8 test string-21.17.$noComp {string trim, unicode} { run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} } "Hello world!" @@ -1693,7 +1972,7 @@ test string-21.25.$noComp {string trimright, unicode} { test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg -} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} -body { list [catch {run {string wordstart a}} msg] $msg } -result {1 {wrong # args: should be "string wordstart string index"}} @@ -1735,6 +2014,12 @@ test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbyt set demo [testbytestring "abc def\xE0\xA9ghi"] run {string index $demo [string wordstart $demo 10]} } -result g +test string-22.15.$noComp {string wordstart, unicode} -body { + run {string wordstart "\U1D7CA\U1D7CA abc" 0} +} -result 0 +test string-22.16.$noComp {string wordstart, unicode} -constraints utf16 -body { + run {string wordstart "\U1D7CA\U1D7CA abc" 10} +} -result 5 test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj { set x 5 @@ -2134,6 +2419,53 @@ test string-29.4.$noComp {string cat, many args} { set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}] list $r1 $r2 } {0 0} +if {$noComp} { +test string-29.5.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.6.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.7.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list] [list]}] +} -match glob -result {*no string representation} +test string-29.8.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.9.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.10.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list x]}] +} -match glob -result {*, string representation "xx"} +test string-29.11.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [list x] [encoding convertto utf-8 {}]}] +} -match glob -result {*no string representation} +test string-29.12.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.13.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat \ + [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.14.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] +} -cleanup { + unset e +} -body { + tcl::unsupported::representation [run {string cat $e $e [list x]}] +} -match glob -result {*no string representation} +test string-29.15.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] + set f [encoding convertto utf-8 {}] +} -cleanup { + unset e f +} -body { + tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}] +} -match glob -result {*no string representation} +} test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} { run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]} @@ -2142,11 +2474,187 @@ test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} } hellohello +# Note: string-31.* tests use [tcl::string::insert] rather than [string insert] +# to dodge ticket [3397978fff] which would cause all arguments to be shared, +# thereby preventing the optimizations from being tested. +test string-31.1.$noComp {string insert, start of string} { + run {tcl::string::insert 0123 0 _} +} _0123 +test string-31.2.$noComp {string insert, middle of string} { + run {tcl::string::insert 0123 2 _} +} 01_23 +test string-31.3.$noComp {string insert, end of string} { + run {tcl::string::insert 0123 4 _} +} 0123_ +test string-31.4.$noComp {string insert, start of string, end-relative} { + run {tcl::string::insert 0123 end-4 _} +} _0123 +test string-31.5.$noComp {string insert, middle of string, end-relative} { + run {tcl::string::insert 0123 end-2 _} +} 01_23 +test string-31.6.$noComp {string insert, end of string, end-relative} { + run {tcl::string::insert 0123 end _} +} 0123_ +test string-31.7.$noComp {string insert, empty target string} { + run {tcl::string::insert {} 0 _} +} _ +test string-31.8.$noComp {string insert, empty insert string} { + run {tcl::string::insert 0123 0 {}} +} 0123 +test string-31.9.$noComp {string insert, empty strings} { + run {tcl::string::insert {} 0 {}} +} {} +test string-31.10.$noComp {string insert, negative index} { + run {tcl::string::insert 0123 -1 _} +} _0123 +test string-31.11.$noComp {string insert, index beyond end} { + run {tcl::string::insert 0123 5 _} +} 0123_ +test string-31.12.$noComp {string insert, start of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} +} _0123 +test string-31.13.$noComp {string insert, middle of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.14.$noComp {string insert, end of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} +} 0123_ +test string-31.15.$noComp {string insert, pure byte array, neither shared} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.16.$noComp {string insert, pure byte array, first shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeByteArray _]} +} 01_23 +test string-31.17.$noComp {string insert, pure byte array, second shared} { + run {tcl::string::insert [makeByteArray 0123] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.18.$noComp {string insert, pure byte array, both shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.19.$noComp {string insert, start of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} +} _0123 +test string-31.20.$noComp {string insert, middle of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} +} 01_23 +test string-31.21.$noComp {string insert, end of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} +} 0123_ +test string-31.22.$noComp {string insert, str start, pure Uni, first shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} +} _0123 +test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} +} 01_23 +test string-31.24.$noComp {string insert, string end, pure Uni, both shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ + [makeShared [makeUnicode _]]} +} 0123_ +test string-31.25.$noComp {string insert, neither byte array nor Unicode} { + run {tcl::string::insert [makeList a b c] 1 zzzzzz} +} {azzzzzz b c} +test string-31.26.$noComp {[11229bad5f] string insert, compiler} -setup { + set i 2 +} -body { + run {tcl::string::insert abcd $i xyz} +} -cleanup { + unset i +} -result abxyzcd + +test string-32.1.$noComp {string is dict} { + string is dict {a b c d} +} 1 +test string-32.1a.$noComp {string is dict} { + string is dict {a b c} +} 0 +test string-32.2.$noComp {string is dict} { + string is dict "a \{b c" +} 0 +test string-32.3.$noComp {string is dict} { + string is dict {a {b c}d e} +} 0 +test string-32.4.$noComp {string is dict} { + string is dict {} +} 1 +test string-32.5.$noComp {string is dict} { + string is dict -strict {a b c d} +} 1 +test string-32.5a.$noComp {string is dict} { + string is dict -strict {a b c} +} 0 +test string-32.6.$noComp {string is dict} { + string is dict -strict "a \{b c" +} 0 +test string-32.7.$noComp {string is dict} { + string is dict -strict {a {b c}d e} +} 0 +test string-32.8.$noComp {string is dict} { + string is dict -strict {} +} 1 +test string-32.9.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b c d}] $x +} {1 {}} +test string-32.9a.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b c}] $x +} {0 -1} +test string-32.10.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "a \{b c d"] $x +} {0 2} +test string-32.10a.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "a \{b c"] $x +} {0 2} +test string-32.11.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b {b c}d e}] $x +} {0 4} +test string-32.12.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {}] $x +} {1 {}} +test string-32.13.$noComp {string is dict} { + set x {} + list [string is dict -failindex x { {b c}d e}] $x +} {0 2} +test string-32.14.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "\uABCD {b c}d e"] $x +} {0 2} +test string-32.15.$noComp {string is dict, valid dict} { + string is dict {a b c d e f} +} 1 +test string-32.16.$noComp {string is dict, invalid dict} { + string is dict a +} 0 +test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { + string is dict {{a b c d e f g h}} +} 0 }; # foreach noComp {0 1} + +test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { + testutf16string deprecated +} -body { + # This simple test suffices because the bug has nothing to do with + # the actual encoding conversion. The test was added because these + # functions are no longer called within the Tcl core and thus + # not tested by either `string`, not `encoding` tests. + testutf16string "abcde" +} -result abcde + # cleanup rename MemStress {} +rename makeByteArray {} +rename makeUnicode {} +rename makeList {} +rename makeShared {} catch {rename foo {}} ::tcltest::cleanupTests return diff --git a/tests/stringComp.test b/tests/stringComp.test deleted file mode 100644 index 95a738c..0000000 --- a/tests/stringComp.test +++ /dev/null @@ -1,801 +0,0 @@ -# Commands covered: string -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# This differs from the original string tests in that the tests call -# things in procs, which uses the compiled string code instead of -# the runtime parse string code. The tests of import should match -# their equivalent number in string.test. -# -# Copyright (c) 2001 by ActiveState Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -# Some tests require the testobj command - -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - set lines [split [memory info] \n] - return [lindex $lines 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -test stringComp-1.1 {error conditions} { - proc foo {} {string gorp a b} - list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test stringComp-1.2 {error conditions} { - proc foo {} {string} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string subcommand ?arg ...?"}} -test stringComp-1.3 {error condition - undefined method during compile} { - # We don't want this to complain about 'never' because it may never - # be called, or string may get redefined. This must compile OK. - proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } - string index $str $i - } - foo abc 0 -} a - -## Test string compare|equal over equal constraints -## Use result for string compare, and negate it for string equal -## The body will be tested both in and outside a proc -set i 0 -foreach {tname tbody tresult tcode} { - {too few args} { - string compare a - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {bad args} { - string compare a b c - } {bad option "a": must be -nocase or -length} {error} - {bad args} { - string compare -length -nocase str1 str2 - } {expected integer but got "-nocase"} {error} - {too many args} { - string compare -length 10 -nocase str1 str2 str3 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {compare with length unspecified} { - string compare -length 10 10 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {basic operation fail} { - string compare abcde abdef - } {-1} {} - {basic operation success} { - string compare abcde abcde - } {0} {} - {with length} { - string compare -length 2 abcde abxyz - } {0} {} - {with special index} { - string compare -length end-3 abcde abxyz - } {expected integer but got "end-3"} {error} - {unicode} { - string compare ab\u7266 ab\u7267 - } {-1} {} - {unicode} {string compare \334 \u00dc} 0 {} - {unicode} {string compare \334 \u00fc} -1 {} - {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} - {high bit} { - # This test fails if the underlying comparison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" - # Nb this tests works also in utf-8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. - } {1} {} - {-nocase 1} {string compare -nocase abcde abdef} {-1} {} - {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} - {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} - {-nocase 4} {string compare -nocase abcde abcde} {0} {} - {-nocase unicode} { - string compare -nocase \334 \u00dc - } 0 {} - {-nocase unicode} { - string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 - } 0 {} - {-nocase with length} { - string compare -length 2 -nocase abcde Abxyz - } {0} {} - {-nocase with length} { - string compare -nocase -length 3 abcde Abxyz - } {-1} {} - {-nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf - } {-1} {} - {-nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde - } {1} {} - {-len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 - } -1 {} - {-nocase with special index} { - string compare -nocase -length end-3 Abcde abxyz - } {expected integer but got "end-3"} error - {null strings} { - string compare "" "" - } 0 {} - {null strings} { - string compare "" foo - } -1 {} - {null strings} { - string compare foo "" - } 1 {} - {-nocase null strings} { - string compare -nocase "" "" - } 0 {} - {-nocase null strings} { - string compare -nocase "" foo - } -1 {} - {-nocase null strings} { - string compare -nocase foo "" - } 1 {} - {with length, unequal strings, partial first string} { - string compare -length 2 abc abde - } 0 {} - {with length, unequal strings 2, full first string} { - string compare -length 2 ab abde - } 0 {} - {with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - string compare \x00 \x01 - } -1 {} - {high bit} { - string compare "a\x80" "a@" - } 1 {} - {high bit} { - string compare "a\x00" "a\x01" - } -1 {} - {high bit} { - string compare "\x00\x00" "\x00\x01" - } -1 {} - {binary equal} { - string compare [binary format a100 0] [binary format a100 0] - } 0 {} - {binary neq} { - string compare [binary format a100a 0 1] [binary format a100a 0 0] - } 1 {} - {binary neq inequal length} { - string compare [binary format a20a 0 1] [binary format a100a 0 0] - } 1 {} -} { - if {$tname eq ""} { continue } - if {$tcode eq ""} { set tcode ok } - test stringComp-2.[incr i] "string compare, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string compare bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult - if {"error" ni $tcode} { - set tresult [expr {!$tresult}] - } else { - set tresult [string map {compare equal} $tresult] - } - set tbody [string map {compare equal} $tbody] - test stringComp-2.[incr i] "string equal, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string equal bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult -} - -# need a few extra tests short abbr cmd -test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string co abcde ABCDE} - foo -} 1 -test stringComp-3.2 {string equal, shortest method name} { - proc foo {} {string e abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal -nocase} { - proc foo {} {string eq -nocase abcde ABCDE} - foo -} 1 - -test stringComp-4.1 {string first, too few args} { - proc foo {} {string first a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.2 {string first, bad args} { - proc foo {} {string first a b c} - list [catch {foo} msg] $msg -} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-4.3 {string first, too many args} { - proc foo {} {string first a b 5 d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.4 {string first} { - proc foo {} {string first bq abcdefgbcefgbqrs} - foo -} 12 -test stringComp-4.5 {string first} { - proc foo {} {string fir bcd abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.6 {string first} { - proc foo {} {string f b abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.7 {string first} { - proc foo {} {string first xxx x123xx345xxx789xxx012} - foo -} 9 -test stringComp-4.8 {string first} { - proc foo {} {string first "" x123xx345xxx789xxx012} - foo -} -1 -test stringComp-4.9 {string first, unicode} { - proc foo {} {string first x abc\u7266x} - foo -} 4 -test stringComp-4.10 {string first, unicode} { - proc foo {} {string first \u7266 abc\u7266x} - foo -} 3 -test stringComp-4.11 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 3} - foo -} 3 -test stringComp-4.12 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 4} - foo -} -1 -test stringComp-4.13 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x end-2} - foo -} 3 -test stringComp-4.14 {string first, negative start index} { - proc foo {} {string first b abc -1} - foo -} 1 - -test stringComp-5.1 {string index} { - proc foo {} {string index} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.2 {string index} { - proc foo {} {string index a b c} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.3 {string index} { - proc foo {} {string index abcde 0} - foo -} a -test stringComp-5.4 {string index} { - proc foo {} {string in abcde 4} - foo -} e -test stringComp-5.5 {string index} { - proc foo {} {string index abcde 5} - foo -} {} -test stringComp-5.6 {string index} { - proc foo {} {string index abcde -10} - list [catch {foo} msg] $msg -} {0 {}} -test stringComp-5.7 {string index} { - proc foo {} {string index a xyz} - list [catch {foo} msg] $msg -} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-5.8 {string index} { - proc foo {} {string index abc end} - foo -} c -test stringComp-5.9 {string index} { - proc foo {} {string index abc end-1} - foo -} b -test stringComp-5.10 {string index, unicode} { - proc foo {} {string index abc\u7266d 4} - foo -} d -test stringComp-5.11 {string index, unicode} { - proc foo {} {string index abc\u7266d 3} - foo -} \u7266 -test stringComp-5.12 {string index, unicode over char length, under byte length} { - proc foo {} {string index \334\374\334\374 6} - foo -} {} -test stringComp-5.13 {string index, bytearray object} { - proc foo {} {string index [binary format a5 fuz] 0} - foo -} f -test stringComp-5.14 {string index, bytearray object} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 3} - foo -} S -test stringComp-5.15 {string index, bytearray object} { - proc foo {} { - set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 - } - foo -} 0 -test stringComp-5.16 {string index, bytearray object with string obj shimmering} { - proc foo {} { - set str "0123456789\x00 abcdedfghi" - binary scan $str H* dump - string compare [string index $str 10] \x00 - } - foo -} 0 -test stringComp-5.17 {string index, bad integer} -body { - proc foo {} {string index "abc" 0o8} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.18 {string index, bad integer} -body { - proc foo {} {string index "abc" end-0o0289} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.19 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} - foo -} {} -test stringComp-5.20 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} - foo -} {} - - -proc largest_int {} { - # This will give us what the largest valid int on this machine is, - # so we can test for overflow properly below on >32 bit systems - set int 1 - set exp 7; # assume we get at least 8 bits - while {$int > 0} { set int [expr {1 << [incr exp]}] } - return [expr {$int-1}] -} - -## string is -## not yet bc - -catch {rename largest_int {}} - -## string last -## not yet bc - -## string length -## not yet bc -test stringComp-8.1 {string bytelength} { - proc foo {} {string bytelength} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.2 {string bytelength} { - proc foo {} {string bytelength a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.3 {string bytelength} { - proc foo {} {string bytelength "\u00c7"} - foo -} 2 -test stringComp-8.4 {string bytelength} { - proc foo {} {string b ""} - foo -} 0 - -## string length -## -test stringComp-9.1 {string length} { - proc foo {} {string length} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.2 {string length} { - proc foo {} {string length a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.3 {string length} { - proc foo {} {string length "a little string"} - foo -} 15 -test stringComp-9.4 {string length} { - proc foo {} {string le ""} - foo -} 0 -test stringComp-9.5 {string length, unicode} { - proc foo {} {string le "abcd\u7266"} - foo -} 5 -test stringComp-9.6 {string length, bytearray object} { - proc foo {} {string length [binary format a5 foo]} - foo -} 5 -test stringComp-9.7 {string length, bytearray object} { - proc foo {} {string length [binary format I* {0x50515253 0x52}]} - foo -} 8 - -## string map -## not yet bc - -## string match -## -test stringComp-11.1 {string match, too few args} { - proc foo {} {string match a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.2 {string match, too many args} { - proc foo {} {string match a b c d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.3 {string match} { - proc foo {} {string match abc abc} - foo -} 1 -test stringComp-11.4 {string match} { - proc foo {} {string mat abc abd} - foo -} 0 -test stringComp-11.5 {string match} { - proc foo {} {string match ab*c abc} - foo -} 1 -test stringComp-11.6 {string match} { - proc foo {} {string match ab**c abc} - foo -} 1 -test stringComp-11.7 {string match} { - proc foo {} {string match ab* abcdef} - foo -} 1 -test stringComp-11.8 {string match} { - proc foo {} {string match *c abc} - foo -} 1 -test stringComp-11.9 {string match} { - proc foo {} {string match *3*6*9 0123456789} - foo -} 1 -test stringComp-11.10 {string match} { - proc foo {} {string match *3*6*9 01234567890} - foo -} 0 -test stringComp-11.11 {string match} { - proc foo {} {string match a?c abc} - foo -} 1 -test stringComp-11.12 {string match} { - proc foo {} {string match a??c abc} - foo -} 0 -test stringComp-11.13 {string match} { - proc foo {} {string match ?1??4???8? 0123456789} - foo -} 1 -test stringComp-11.14 {string match} { - proc foo {} {string match {[abc]bc} abc} - foo -} 1 -test stringComp-11.15 {string match} { - proc foo {} {string match {a[abc]c} abc} - foo -} 1 -test stringComp-11.16 {string match} { - proc foo {} {string match {a[xyz]c} abc} - foo -} 0 -test stringComp-11.17 {string match} { - proc foo {} {string match {12[2-7]45} 12345} - foo -} 1 -test stringComp-11.18 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12345} - foo -} 1 -test stringComp-11.19 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12b45} - foo -} 1 -test stringComp-11.20 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12d45} - foo -} 1 -test stringComp-11.21 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12145} - foo -} 0 -test stringComp-11.22 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12545} - foo -} 0 -test stringComp-11.23 {string match} { - proc foo {} {string match {a\*b} a*b} - foo -} 1 -test stringComp-11.24 {string match} { - proc foo {} {string match {a\*b} ab} - foo -} 0 -test stringComp-11.25 {string match} { - proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} - foo -} 1 -test stringComp-11.26 {string match} { - proc foo {} {string match ** ""} - foo -} 1 -test stringComp-11.27 {string match} { - proc foo {} {string match *. ""} - foo -} 0 -test stringComp-11.28 {string match} { - proc foo {} {string match "" ""} - foo -} 1 -test stringComp-11.29 {string match} { - proc foo {} {string match \[a a} - foo -} 1 -test stringComp-11.30 {string match, bad args} { - proc foo {} {string match - b c} - list [catch {foo} msg] $msg -} {1 {bad option "-": must be -nocase}} -test stringComp-11.31 {string match case} { - proc foo {} {string match a A} - foo -} 0 -test stringComp-11.32 {string match nocase} { - proc foo {} {string match -n a A} - foo -} 1 -test stringComp-11.33 {string match nocase} { - proc foo {} {string match -nocase a\334 A\374} - foo -} 1 -test stringComp-11.34 {string match nocase} { - proc foo {} {string match -nocase a*f ABCDEf} - foo -} 1 -test stringComp-11.35 {string match case, false hope} { - # This is true because '_' lies between the A-Z and a-z ranges - proc foo {} {string match {[A-z]} _} - foo -} 1 -test stringComp-11.36 {string match nocase range} { - # This is false because although '_' lies between the A-Z and a-z ranges, - # we lower case the end points before checking the ranges. - proc foo {} {string match -nocase {[A-z]} _} - foo -} 0 -test stringComp-11.37 {string match nocase} { - proc foo {} {string match -nocase {[A-fh-Z]} g} - foo -} 0 -test stringComp-11.38 {string match case, reverse range} { - proc foo {} {string match {[A-fh-Z]} g} - foo -} 1 -test stringComp-11.39 {string match, *\ case} { - proc foo {} {string match {*\abc} abc} - foo -} 1 -test stringComp-11.40 {string match, *special case} { - proc foo {} {string match {*[ab]} abc} - foo -} 0 -test stringComp-11.41 {string match, *special case} { - proc foo {} {string match {*[ab]*} abc} - foo -} 1 -test stringComp-11.42 {string match, *special case} { - proc foo {} {string match "*\\" "\\"} - foo -} 0 -test stringComp-11.43 {string match, *special case} { - proc foo {} {string match "*\\\\" "\\"} - foo -} 1 -test stringComp-11.44 {string match, *special case} { - proc foo {} {string match "*???" "12345"} - foo -} 1 -test stringComp-11.45 {string match, *special case} { - proc foo {} {string match "*???" "12"} - foo -} 0 -test stringComp-11.46 {string match, *special case} { - proc foo {} {string match "*\\*" "abc*"} - foo -} 1 -test stringComp-11.47 {string match, *special case} { - proc foo {} {string match "*\\*" "*"} - foo -} 1 -test stringComp-11.48 {string match, *special case} { - proc foo {} {string match "*\\*" "*abc"} - foo -} 0 -test stringComp-11.49 {string match, *special case} { - proc foo {} {string match "?\\*" "a*"} - foo -} 1 -test stringComp-11.50 {string match, *special case} { - proc foo {} {string match "\\" "\\"} - foo -} 0 -test stringComp-11.51 {string match; *, -nocase and UTF-8} { - proc foo {} {string match -nocase [binary format I 717316707] \ - [binary format I 2028036707]} - foo -} 1 -test stringComp-11.52 {string match, null char in string} { - proc foo {} { - set ptn "*abc*" - foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 1 1 1} -test stringComp-11.53 {string match, null char in pattern} { - proc foo {} { - set out "" - foreach {ptn elem} [list \ - "*\u0000abc\u0000" "\u0000abc\u0000" \ - "*\u0000abc\u0000" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ - ] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 0 1 0 1} -test stringComp-11.54 {string match, failure} { - proc foo {} { - set longString "" - for {set i 0} {$i < 10} {incr i} { - append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" - } - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] - } - foo -} {0 1 1 1 0 0} - -## string range -test stringComp-12.1 {Bug 3588366: end-offsets before start} { - apply {s { - string range $s 0 end-5 - }} 12345 -} {} - -## string repeat -## not yet bc - -## string replace -test stringComp-14.1 {Bug 82e7f67325} { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} -} {3 3} -test stringComp-14.2 {Bug 82e7f67325} memory { - # As in stringComp-14.1, but make sure we don't retain too many refs - leaktest { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} - } -} {0} -test stringComp-14.3 {Bug 0dca3bfa8f} { - apply {arg { - set argCopy $arg - set arg [string replace $arg 1 2 aa] - # Crashes in comparison before fix - expr {$arg ne $argCopy} - }} abcde -} 1 -test stringComp-14.4 {Bug 1af8de570511} { - apply {{x y} { - # Generate an unshared string value - set val "" - for { set i 0 } { $i < $x } { incr i } { - set val [format "0%s" $val] - } - string replace $val[unset val] 1 1 $y - }} 4 x -} 0x00 -test stringComp-14.5 {} { - string length [string replace [string repeat a\u00fe 2] 3 end {}] -} 3 - -## string tolower -## not yet bc - -## string toupper -## not yet bc - -## string totitle -## not yet bc - -## string trim* -## not yet bc - -## string word* -## not yet bc - -## string cat -test stringComp-29.1 {string cat, no arg} { - proc foo {} {string cat} - foo -} "" -test stringComp-29.2 {string cat, single arg} { - proc foo {} { - set x FOO - string compare $x [string cat $x] - } - foo -} 0 -test stringComp-29.3 {string cat, two args} { - proc foo {} { - set x FOO - string compare $x$x [string cat $x $x] - } - foo -} 0 -test stringComp-29.4 {string cat, many args} { - proc foo {} { - set x FOO - set n 260 - set xx [string repeat $x $n] - set vv [string repeat {$x} $n] - set vvs [string repeat {$x } $n] - set r1 [string compare $xx [subst $vv]] - set r2 [string compare $xx [eval "string cat $vvs"]] - list $r1 $r2 - } - foo -} {0 0} - - -# cleanup -catch {rename foo {}} -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: diff --git a/tests/stringObj.test b/tests/stringObj.test index 2c91546..60e1294 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -6,8 +6,8 @@ # 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. @@ -18,13 +18,16 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] - -test stringObj-1.1 {string type registration} testobj { +testConstraint tip389 [expr {[string length \U010000] == 2}] +testConstraint utf32 [expr {[string length [format %c 0x10000]] == 1}] + +test stringObj-1.1 {string type registration} {testobj deprecated} { set t [testobj types] set first [string first "string" $t] set result [expr {$first >= 0}] @@ -55,27 +58,27 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob lappend result [testobj refcount 1] } {{} 512 foo string 2} -test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} testobj { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {3 4 tes} -test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { +} {3 3 tes} +test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} { testobj freeallvars teststringobj set 1 abcdef teststringobj setlength 1 10 teststringobj length 1 } 10 -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {10 20 abcdefxyzq} -test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj { +} {10 10 abcdefxyzq} +test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj setlength 1 0 @@ -95,7 +98,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj { teststringobj append 1 123 -1 teststringobj get 1 } {x y bbCC123} -test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -107,7 +110,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj { teststringobj append 1 abcdef -1 lappend result [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {15 15 16 32 xy12345678abcdef} +} {15 15 16 16 xy12345678abcdef} test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj { testobj freeallvars @@ -133,13 +136,13 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj { teststringobj appendstrings 1 { 123 } abcdefg list [teststringobj length 1] [teststringobj get 1] } {15 {abc 123 abcdefg}} -test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj utf32 deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] -} {10 20 123abcdefg} -test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { +} {10 10 123abcdefg} +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -148,7 +151,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testob list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 ab34567890} -test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -156,8 +159,8 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testob teststringobj appendstrings 1 34567890x list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {11 22 ab34567890x} -test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj { +} {11 11 ab34567890x} +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -170,14 +173,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj { teststringobj get 1 } adcfoobarsoom -test stringObj-7.1 {SetStringFromAny procedure} testobj { +test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32 deprecated} { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {4 8 {a bx}} -test stringObj-7.2 {SetStringFromAny procedure, null object} testobj { +} {4 4 {a bx}} +test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -195,7 +198,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj { [string length $x] [testobj objtype $x] } {6 string 6 string} -test stringObj-8.1 {DupStringInternalRep procedure} testobj { +test stringObj-8.1 {DupStringInternalRep procedure} {testobj utf32 deprecated} { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 @@ -204,21 +207,21 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj { [teststringobj maxchars 1] [teststringobj get 1] \ [teststringobj length 2] [teststringobj length2 2] \ [teststringobj maxchars 2] [teststringobj get 2] -} {5 10 0 abcde 5 5 0 abcde} +} {5 5 5 abcde 5 5 5 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 @@ -235,31 +238,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 @@ -277,14 +280,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}] @@ -305,19 +308,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 @@ -326,7 +329,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 @@ -336,41 +339,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 - # hard-coding 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 hard-coding 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 hard-coding 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 { @@ -392,15 +384,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 "" @@ -414,19 +406,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 hard-coding 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 hard-coding 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} { @@ -439,9 +431,9 @@ test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestr test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { teststringobj set 1 foo - teststringobj getunicode 1 + teststringobj maxchars 1 teststringobj append 1 bar -1 - teststringobj getunicode 1 + teststringobj maxchars 1 teststringobj append 1 bar -1 teststringobj setlength 1 0 teststringobj append 1 bar -1 @@ -464,53 +456,52 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 3 } foo -test stringObj-16.0 {Tcl_GetRange: normal case} testobj { +test stringObj-16.0 {Tcl_GetRange: normal case} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 1 3 } bcd -test stringObj-16.1 {Tcl_GetRange: first > end} testobj { +test stringObj-16.1 {Tcl_GetRange: first > end} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 10 5 } {} -test stringObj-16.2 {Tcl_GetRange: last > end} testobj { +test stringObj-16.2 {Tcl_GetRange: last > end} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 3 13 } de -test stringObj-16.3 {Tcl_GetRange: first = -1} testobj { +test stringObj-16.3 {Tcl_GetRange: first = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 -1 3 } abcd -test stringObj-16.4 {Tcl_GetRange: last = -1} testobj { +test stringObj-16.4 {Tcl_GetRange: last = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 1 -1 } bcde -test stringObj-16.5 {Tcl_GetRange: fist = last = -1} testobj { +test stringObj-16.5 {Tcl_GetRange: fist = last = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj { +test stringObj-16.6 {Tcl_GetRange: old anomaly} {testobj deprecated} { # Older implementations could return "cde" teststringobj set 1 abcde teststringobj range 1 2 0 } {} - if {[testConstraint testobj]} { testobj freeallvars @@ -519,3 +510,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/subst.test b/tests/subst.test index 8a8b3f1..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 {"::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 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 diff --git a/tests/switch.test b/tests/switch.test index a7211cb..3d106c0 100644 --- a/tests/switch.test +++ b/tests/switch.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) 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. diff --git a/tests/tailcall.test b/tests/tailcall.test index 6b09cde..0016845 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -4,7 +4,7 @@ # 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 d16c76b..114ce30 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 Scriptics Corporation. -# Copyright (c) 2000 Ajuba Solutions +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # All rights reserved. # Note that there are several places where the value of @@ -18,7 +18,7 @@ # if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 1a473e9..61366a4 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -5,14 +5,22 @@ if {[package provide tcltests] ne {}} return package require tcltest 2.5 namespace import ::tcltest::* - -testConstraint exec [llength [info commands exec]] +testConstraint exec [llength [info commands exec]] +testConstraint deprecated [expr {![tcl::build-info no-deprecate]}] +testConstraint debug [tcl::build-info debug] +testConstraint purify [tcl::build-info purify] +testConstraint debugpurify [ + expr { + ![tcl::build-info memdebug] + && [testConstraint debug] + && [testConstraint purify] + }] testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] -testConstraint thread [ - expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint thread [expr {![catch {package require Thread 2.7-}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] + namespace eval ::tcltests { @@ -26,6 +34,18 @@ namespace eval ::tcltests { } + # Stolen from dict.test + proc scriptmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } + + proc tempdir_alternate {} { close [file tempfile tempfile] set tmpdir [file dirname $tempfile] @@ -45,5 +65,5 @@ namespace eval ::tcltests { init package provide tcltests 0.1 - } + diff --git a/tests/thread.test b/tests/thread.test index 92f3a06..636d7a8 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -4,13 +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) 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.5 + namespace import -force ::tcltest::* +} # when thread::release is used, -wait is passed in order allow the thread to # be fully finalized, which avoids valgrind "still reachable" reports. @@ -19,7 +23,7 @@ package require tcltest 2.5 source [file join [file dirname [info script]] tcltests.tcl] ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Some tests require the testthread command diff --git a/tests/timer.test b/tests/timer.test index 48d88b6..52c0b8a 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -7,8 +7,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) 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. @@ -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 { diff --git a/tests/tm.test b/tests/tm.test index ed14567..a1959e6 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -3,10 +3,9 @@ # 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.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 c1e1a24..d3c2dad 100644 --- a/tests/trace.test +++ b/tests/trace.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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -76,26 +76,26 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" unset -nocomplain ::z - trace variable ::z w {unset ::z; error "memory corruption";#} + trace add variable ::z write {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} # Read-tracing on variables -test trace-1.1 {trace variable reads} { +test trace-1.1 {trace add variable reads} { unset -nocomplain x set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} -test trace-1.2 {trace variable reads} { +test trace-1.2 {trace add variable reads} { unset -nocomplain x set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} -test trace-1.3 {trace variable reads} { +test trace-1.3 {trace add variable reads} { unset -nocomplain x set info {} trace add variable x read traceScalar @@ -156,7 +156,7 @@ test trace-1.9 {trace reads on whole arrays} { trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} -test trace-1.10 {trace variable reads} { +test trace-1.10 {trace add variable reads} { unset -nocomplain x set x 444 set info {} @@ -167,35 +167,35 @@ test trace-1.10 {trace variable reads} { test trace-1.11 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x(bar) ;#} + trace add variable x read {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {unset -nocomplain x(bar) ;#} - trace variable x r {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x(bar) ;#} + trace add variable x read {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x;#} + trace add variable x read {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {unset -nocomplain x;#} - trace variable x r {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x;#} + trace add variable x read {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables -test trace-2.1 {trace variable writes} { +test trace-2.1 {trace add variable writes} { unset -nocomplain x set info {} trace add variable x write traceScalar @@ -216,7 +216,7 @@ test trace-2.3 {trace writes on whole arrays} { set x(abc) qq set info } {x abc write 0 qq} -test trace-2.4 {trace variable writes} { +test trace-2.4 {trace add variable writes} { unset -nocomplain x set x 1234 set info {} @@ -224,7 +224,7 @@ test trace-2.4 {trace variable writes} { set x set info } {} -test trace-2.5 {trace variable writes} { +test trace-2.5 {trace add variable writes} { unset -nocomplain x set x 1234 set info {} @@ -232,7 +232,7 @@ test trace-2.5 {trace variable writes} { unset x set info } {} -test trace-2.6 {trace variable writes on compiled local} { +test trace-2.6 {trace add variable writes on compiled local} { # # Check correct function of whole array traces on compiled local # arrays [Bug 1770591]. The corresponding function for read traces is @@ -247,7 +247,7 @@ test trace-2.6 {trace variable writes on compiled local} { p set info } {x X write 0 willy} -test trace-2.7 {trace variable writes on errorInfo} -body { +test trace-2.7 {trace add variable writes on errorInfo} -body { # # Check correct behaviour of write traces on errorInfo. # [Bug 1773040] @@ -266,7 +266,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body { # still trigger these read traces. Also lappend triggers only one write # trace: after appending all arguments to the list. -test trace-3.1 {trace variable read-modify-writes} { +test trace-3.1 {trace add variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x read traceScalarAppend @@ -275,7 +275,7 @@ test trace-3.1 {trace variable read-modify-writes} { lappend x 789 set info } {x {} read 0 123456} -test trace-3.2 {trace variable read-modify-writes} { +test trace-3.2 {trace add variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend @@ -286,7 +286,7 @@ test trace-3.2 {trace variable read-modify-writes} { # Basic unset-tracing on variables -test trace-4.1 {trace variable unsets} { +test trace-4.1 {trace add variable unsets} { unset -nocomplain x set info {} trace add variable x unset traceScalar @@ -397,10 +397,10 @@ test trace-5.4 {array traces properly listed in trace information} { } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { unset -nocomplain x - trace variable x a traceArray2 - set result [trace vinfo x] + trace add variable x array traceArray2 + set result [trace info variable x] set result -} [list [list a traceArray2]] +} [list [list array traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { unset -nocomplain x set x foo @@ -1241,7 +1241,7 @@ test trace-18.2 {namespace delete / trace vdelete combo} { proc p1 args { trace vdelete ::foo::x u p1 } - trace variable ::foo::x u p1 + trace add variable ::foo::x unset p1 namespace delete ::foo info exists ::foo::x } 0 @@ -2420,7 +2420,7 @@ test trace-32.1 { test trace-33.1 {variable match with remove variable} { unset -nocomplain x - trace variable x w foo + trace add variable x write foo trace remove variable x write foo llength [trace info variable x] } 0 diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 8ac3ccc..09a34dd 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -4,7 +4,7 @@ # 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] # File permissions broken on wsl without some "exotic" wsl configuration @@ -98,7 +98,7 @@ test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup { cleanup } -constraints {unix notRoot notWsl} -body { file mkdir td1/td2/td3 - file attributes td1/td2 -permissions 0o000 + file attributes td1/td2 -permissions 0 file rename td1/td2/td3 td2 } -returnCodes error -cleanup { file attributes td1/td2 -permissions 0o755 @@ -112,7 +112,7 @@ test unixFCmd-1.2 {TclpRenameFile: EEXIST} -setup { file rename td2 td1 } -returnCodes error -cleanup { cleanup -} -result {error renaming "td2" to "td1/td2": file already exists} +} -result {error renaming "td2" to "td1/td2": file exists} test unixFCmd-1.3 {TclpRenameFile: EINVAL} -setup { cleanup } -constraints {unix notRoot} -body { @@ -225,7 +225,7 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { close [open tf1 a] file attributes tf1 -permissions 0o472 file copy tf1 tf2 - format 0o%03o [file attributes tf2 -permissions] + file attributes tf2 -permissions } -cleanup { cleanup } -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- @@ -338,15 +338,15 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot notWsl} -body { close [open foo.test w] - list [file attributes foo.test -permissions 0o000] \ - [format 0o%03o [file attributes foo.test -permissions]] + list [file attributes foo.test -permissions 0] \ + [file attributes foo.test -permissions] } -cleanup { file delete -force -- foo.test -} -result {{} 0o000} +} -result {{} 00000} test unixFCmd-17.2 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot} -returnCodes error -body { - file attributes foo.test -permissions 0o000 + 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} @@ -372,16 +372,16 @@ proc permcheck {testnum permList expected} { set result {} foreach permstr $permList { file attributes foo.test -permissions $permstr - lappend result [format 0o%03o [file attributes foo.test -permissions]] + lappend result [file attributes foo.test -permissions] } set result } $expected } permcheck unixFCmd-17.5 rwxrwxrwx 0o777 permcheck unixFCmd-17.6 r--r---w- 0o442 -permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {0o000 0o740 0o540 0o547} +permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547} permcheck unixFCmd-17.11 --x--x--x 0o111 -permcheck unixFCmd-17.12 {0 a+rwx} {0o000 0o777} +permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { @@ -392,7 +392,7 @@ test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { set nd $cd/tstdir file mkdir $nd cd $nd - file attributes $nd -permissions 0o000 + file attributes $nd -permissions 0 pwd } -returnCodes error -cleanup { cd $cd diff --git a/tests/unixFile.test b/tests/unixFile.test index 3669cce..e2a634a 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -4,7 +4,7 @@ # 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index a4270d6..bf22449 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.5 -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 51ecafe..8e64c7a 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -4,17 +4,22 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.5 -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 + +# Some tests require the testgetencpath command +testConstraint testgetencpath [llength [info commands testgetencpath]] test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} @@ -87,13 +92,15 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} skip [concat [skip] unixInit-2.*] -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { - set origDir [testgetdefenc] - testsetdefenc slappy - set path [testgetdefenc] - testsetdefenc $origDir +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { + testgetencpath +} -body { + set origPath [testgetencpath] + testsetencpath slappy + set path [testgetencpath] + testsetencpath $origPath set path -} {slappy} +} -result {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -119,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 { @@ -151,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) @@ -159,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 } {} @@ -339,7 +346,9 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} -} -constraints {unix stdio} -body { + catch {set oldtcl_library $env(TCL_LIBRARY)} + unset -nocomplain env(TCL_LIBRARY) +} -constraints {unix stdio knownBug} -body { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] @@ -357,6 +366,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { } -cleanup { unset -nocomplain env(LANG) env(LC_ALL) catch {set env(LC_ALL) $oldlc_all} + catch {set env(TCL_LIBRARY) $oldtcl_library} } -result 0 test unixInit-4.1 {TclpSetVariables} {unix} { diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 7d32555..8ab0edb 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -4,8 +4,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) 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. @@ -18,16 +18,11 @@ if {"::tcltest" ni [namespace children]} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] -# Darwin always uses a threaded notifier -testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" -}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} @@ -38,7 +33,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] diff --git a/tests/unknown.test b/tests/unknown.test index 7600cba..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.5 -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 0b10492..24b5e8d 100644 --- a/tests/unload.test +++ b/tests/unload.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) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2003-2004 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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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. @@ -53,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 } {} @@ -77,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 \ @@ -100,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] @@ -111,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 @@ -132,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 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}] @@ -152,14 +152,14 @@ 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 { +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 { +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 } @@ -169,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 @@ -181,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 @@ -189,7 +189,7 @@ test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, w } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] Pkgua child] \ + [unload [file join $testDir pkgua$ext] pKgUa child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{.. . .} {} {} {.. .. ..}} @@ -203,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 "" @@ -215,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 "" @@ -224,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] } @@ -259,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 } @@ -274,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 } @@ -291,7 +291,7 @@ test unload-5.1 {unload a module loaded from vfs} \ set dir [pwd] cd $testDir testsimplefilesystem 1 - load simplefs:/pkgua$ext Pkgua + load simplefs:/pkgua$ext pkgua } \ -body { list [catch {unload simplefs:/pkgua$ext} msg] $msg diff --git a/tests/uplevel.test b/tests/uplevel.test index fa3be92..de21361 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.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-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. @@ -147,27 +147,27 @@ test uplevel-4.15 {level parsing} { test uplevel-4.16 {level parsing} { apply {{} {uplevel #[expr 1] {}}} } {} -test uplevel-4.17 {level parsing} { +test uplevel-4.17 {level parsing} -returnCodes error -body { apply {{} {uplevel -0xffffffff {}}} -} {} -test uplevel-4.18 {level parsing} { +} -result {bad level "-0xffffffff"} +test uplevel-4.18 {level parsing} -returnCodes error -body { apply {{} {uplevel #-0xffffffff {}}} -} {} -test uplevel-4.19 {level parsing} { +} -result {bad level "#-0xffffffff"} +test uplevel-4.19 {level parsing} -returnCodes error -body { apply {{} {uplevel [expr -0xffffffff] {}}} -} {} -test uplevel-4.20 {level parsing} { +} -result {bad level "-4294967295"} +test uplevel-4.20 {level parsing} -returnCodes error -body { apply {{} {uplevel #[expr -0xffffffff] {}}} -} {} +} -result {bad level "#-4294967295"} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} @@ -185,13 +185,13 @@ test uplevel-4.28 {level parsing} -body { } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -203,7 +203,7 @@ test uplevel-4.34 {level parsing} -body { } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} diff --git a/tests/upvar.test b/tests/upvar.test index 9e44a79..8a1319e 100644 --- a/tests/upvar.test +++ b/tests/upvar.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-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. @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -187,26 +187,26 @@ test upvar-4.2 {nested upvars} { proc tproc {args} {global x; set x [list $args [uplevel info vars]]} test upvar-5.1 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write} tproc; p2} proc p2 {} {upvar c x1; set x1 22} set x --- p1 foo bar set x -} {{x1 {} w} x1} +} {{x1 {} write} x1} test upvar-5.2 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write} tproc; p2} proc p2 {} {upvar c x1; set x1} set x --- p1 foo bar set x -} {{x1 {} r} x1} +} {{x1 {} read} x1} test upvar-5.3 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write unset} tproc; p2} proc p2 {} {upvar c x1; unset x1} set x --- p1 foo bar set x -} {{x1 {} u} x1} +} {{x1 {} unset} x1} test upvar-6.1 {retargeting an upvar} { proc p1 {} { @@ -249,6 +249,33 @@ test upvar-6.3 {retargeting an upvar} { p1 } {abcde 44} + + +test upvar-6.4 { + retargeting a variable created by upvar to itself is allowed +} -body { + catch { + unset x + } + catch { + unset y + } + set res {} + set x abcde + set res [catch { + upvar 0 x x + } cres copts] + lappend res [dict get $copts -errorcode] + upvar 0 x y + lappend res $y + upvar 0 y y + lappend res $y + return $res +} -cleanup { + upvar 0 {} y +} -result {1 {TCL UPVAR SELF} abcde abcde} + + test upvar-7.1 {upvar to same level} { set x 44 set y 55 @@ -328,7 +355,7 @@ test upvar-8.6 {errors in upvar command} -returnCodes error -body { p1 } -result {variable "a" already exists} test upvar-8.7 {errors in upvar command} -returnCodes error -body { - proc p1 {} {trace variable a w foo; upvar b a} + proc p1 {} {trace add variable a write foo; upvar b a} p1 } -result {variable "a" has traces: can't use for upvar} test upvar-8.8 {create nested array with upvar} -body { diff --git a/tests/utf.test b/tests/utf.test index 871bdc8..5a6bbd4 100644 --- a/tests/utf.test +++ b/tests/utf.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) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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. @@ -14,7 +14,9 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] + +source [file join [file dirname [info script]] tcltests.tcl] testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] @@ -49,7 +51,7 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { expr {"\xE0" eq [testbytestring \xC3\xA0]} } 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]} + 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]} @@ -84,6 +86,25 @@ test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { 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} { + set lo \uDE02 + return \uD83D$lo +} \uD83D\uDE02 +test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} { + set hi \uD83D + return $hi\uDE02 +} \uD83D\uDE02 +test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring { + set lo [testbytestring \x80] + string length [testbytestring \xC0]$lo +} 2 +test utf-1.17 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring { + set hi [testbytestring \xC0] + string length $hi[testbytestring \x80] +} 2 +test utf-1.18 {Tcl_UniCharToUtf: surrogate pairs from concat} { + string cat \uD83D \uDE02 +} \uD83D\uDE02 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -110,10 +131,10 @@ test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testb 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 \U010000 + string length 𐀀 } 2 test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 { - string length \U010000 + string length 𐀀 } 1 test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { string length [testbytestring \xF4\x8F\xBF\xBF] @@ -172,12 +193,9 @@ test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars t test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 -test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { +test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring deprecated} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 2 -test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring utf32} { - 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 @@ -354,7 +372,7 @@ test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xA0]G } 1 test utf-6.51 {Tcl_UtfNext} testutfnext { - testutfnext \u8820 + testutfnext 蠠 } 3 test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xA0\xD0] @@ -387,22 +405,22 @@ test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2\xA0\xF8] } 1 test utf-6.62 {Tcl_UtfNext} testutfnext { - testutfnext \u8820G + testutfnext 蠠G } 3 test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xE8\xA0\xA0\xA0] } 3 test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xD0] + testutfnext 蠠[testbytestring \xD0] } 3 test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xE8] + testutfnext 蠠[testbytestring \xE8] } 3 test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xF2] + testutfnext 蠠[testbytestring \xF2] } 3 test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xF8] + testutfnext 蠠[testbytestring \xF8] } 3 test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} { testutfnext [testbytestring \xF2\xA0\xA0]G @@ -533,127 +551,6 @@ test utf-6.95.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} { 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-6.96 {Tcl_UtfNext, read limits} testutfnext { - testutfnext G 0 -} 0 -test utf-6.97 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0] 0 -} 0 -test utf-6.98 {Tcl_UtfNext, read limits} testutfnext { - testutfnext AG 1 -} 1 -test utf-6.99 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext A[testbytestring \xA0] 1 -} 1 -test utf-6.100 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xD0\xA0]G 1 -} 0 -test utf-6.101 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xD0\xA0]G 2 -} 2 -test utf-6.102 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xD0\xA0\xA0] 1 -} 0 -test utf-6.103 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xD0\xA0\xA0] 2 -} 2 -test utf-6.104 {Tcl_UtfNext, read limits} testutfnext { - testutfnext \u8820G 1 -} 0 -test utf-6.105 {Tcl_UtfNext, read limits} testutfnext { - testutfnext \u8820G 2 -} 0 -test utf-6.106 {Tcl_UtfNext, read limits} testutfnext { - testutfnext \u8820G 3 -} 3 -test utf-6.107 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xA0] 1 -} 0 -test utf-6.108 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xA0] 2 -} 0 -test utf-6.109 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext \u8820[testbytestring \xA0] 3 -} 3 -# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext -test utf-6.110 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 1 -} 0 -# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext -test utf-6.111 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 2 -} 0 -test utf-6.112.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3 -} 1 -test utf-6.112.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3 -} 0 -test utf-6.113.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4 -} 1 -test utf-6.113.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4 -} 4 -# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext -test utf-6.114 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 1 -} 0 -# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext -test utf-6.115 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 2 -} 0 -test utf-6.116.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3 -} 1 -test utf-6.116.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3 -} 0 -test utf-6.117.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4 -} 1 -test utf-6.117.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4 -} 4 -test utf-6.118 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0]G 0 -} 0 -test utf-6.119 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0]G 1 -} 0 -test utf-6.120 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0\xA0] 1 -} 0 -test utf-6.121 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0\xA0]G 2 -} 0 -test utf-6.122 {Tcl_UtfNext, read limits} {testutfnext testbytestring} { - testutfnext [testbytestring \xA0\xA0\xA0] 2 -} 0 -test utf-6.123.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xA0\xA0\xA0]G 3 -} 1 -test utf-6.123.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xA0\xA0\xA0]G 3 -} 3 -test utf-6.124.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3 -} 1 -test utf-6.124.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3 -} 3 -test utf-6.125.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4 -} 1 -test utf-6.125.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4 -} 3 -test utf-6.126.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4 -} 1 -test utf-6.126.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} { - testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4 -} 3 test utf-7.1 {Tcl_UtfPrev} testutfprev { testutfprev {} @@ -794,13 +691,13 @@ test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 } 1 test utf-7.16 {Tcl_UtfPrev} testutfprev { - testutfprev A\u8820 + testutfprev A蠠 } 1 test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xE8\xA0\xA0\xA0] 4 } 1 test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} { - testutfprev A\u8820[testbytestring \xF8] 4 + testutfprev A蠠[testbytestring \xF8] 4 } 1 test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xD0\xA0\xA0] @@ -926,7 +823,7 @@ test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {test testutfprev [testbytestring \xE8\xA0] } 0 test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { - testutfprev \u8820 2 + testutfprev 蠠 2 } 0 test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 @@ -969,14 +866,14 @@ 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 -} \xFF + string index 乎ɚÿՃ 2 +} ÿ test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { string index \uD842 0 } \uD842 @@ -993,116 +890,116 @@ test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { string index \uD83D\uDE00G 0 } \uD83D test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} utf32 { - string index \U1F600G 0 -} \U1F600 + string index 😀G 0 +} 😀 test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 0 -} \U1F600 + 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} utf32 { - string index \U1F600G 1 + string index 😀G 1 } G test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 1 + 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} utf32 { - string index \U1F600G 2 + string index 😀G 2 } {} test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 2 + string index 😀G 2 } G -test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 0 +test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 0 } \uFFFD test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} utf32 { - string index \U1F600G 0 -} \U1F600 + string index 😀G 0 +} 😀 test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 0 -} \U1F600 -test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 1 + 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} utf32 { - string index \U1F600G 1 + string index 😀G 1 } G test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 1 + string index 😀G 1 } {} -test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { - string index \U1F600G 2 +test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 2 } {} test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} utf32 { - string index \U1F600G 2 + string index 😀G 2 } {} test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 { - string index \U1F600G 2 + 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 + 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} utf32 { - string range \U1F600G 0 0 -} \U1F600 + string range 😀G 0 0 +} 😀 test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { - string range \U1F600G 0 0 -} \U1F600 + 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} utf32 { - string range \U1F600G 1 1 + string range 😀G 1 1 } G test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \U1F600G 1 1 + 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} utf32 { - string range \U1F600G 2 2 + string range 😀G 2 2 } {} test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \U1F600G 2 2 + string range 😀G 2 2 } G -test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} { - string range \U1F600G 0 0 +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} utf32 { - string range \U1F600G 0 0 -} \U1F600 + string range 😀G 0 0 +} 😀 test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { - string range \U1F600G 0 0 -} \U1F600 -test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { - string range \U1F600G 1 1 + 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} utf32 { - string range \U1F600G 1 1 + string range 😀G 1 1 } G test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \U1F600G 1 1 + string range 😀G 1 1 } {} -test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { - string range \U1F600G 2 2 +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} utf32 { - string range \U1F600G 2 2 + string range 😀G 2 2 } {} test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { - string range \U1F600G 2 2 + string range 😀G 2 2 } G test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { @@ -1205,17 +1102,17 @@ 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 + string toupper აᲐ +} ᲐᲐ test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf { - string toupper \U10428 -} \U10400 + string toupper 𐐨 +} 𐐀 test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf { - string toupper \uD801\uDC28 -} \uD801\uDC00 + string toupper 𐐨 +} 𐐀 test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} { string toupper \uDC24\uD824 } \uDC24\uD824 @@ -1227,23 +1124,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 + 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 \U10400 -} \U10428 + string tolower 𐐀 +} 𐐨 test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf { - string tolower \uD801\uDC00 -} \uD801\uDC28 + string tolower 𐐀 +} 𐐨 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -1252,26 +1149,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 \U10428\U10400 -} \U10400\U10428 + string totitle 𐐨𐐀 +} 𐐀𐐨 test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf { - string totitle \uD801\uDC28\uD801\uDC00 -} \uD801\uDC00\uD801\uDC28 + string totitle 𐐨𐐀 +} 𐐀𐐨 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b @@ -1290,8 +1187,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 ! } ! @@ -1300,25 +1197,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 -} \xFF\xFF\u0265\u01C6 + 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 ! } ! @@ -1332,7 +1229,7 @@ test utf-19.1 {TclUniCharLen} -body { test utf-20.1 {TclUniCharNcmp} utf32 { string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] } -1 -test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} { +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} utf32 { set one [format %c 0xFFFF] set two [format %c 0x10000] set first [string compare $one $two] @@ -1344,23 +1241,23 @@ test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} { 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] @@ -1395,25 +1292,25 @@ 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} { @@ -1442,8 +1339,8 @@ proc UniCharCaseCmpTest {order one two {constraints {}}} { } -body { teststringobj set 1 $one teststringobj set 2 $two - teststringobj getunicode 1 - teststringobj getunicode 2 + teststringobj maxchars 1 + teststringobj maxchars 2 set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]] if {$result eq [string map {< -1 = 0 > 1} $order]} { set result ok @@ -1471,7 +1368,7 @@ test utf-26.1 {Tcl_UniCharDString} -setup { testobj freeallvars } -body { teststringobj set 1 foo - teststringobj getunicode 1 + teststringobj maxchars 1 teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10 scan [string index [teststringobj get 1] 11] %c } -result 128 diff --git a/tests/utfext.test b/tests/utfext.test new file mode 100644 index 0000000..ce50666 --- /dev/null +++ b/tests/utfext.test @@ -0,0 +1,90 @@ +# This file contains a collection of tests for Tcl_UtfToExternal and +# Tcl_UtfToExternal. Sourcing this file into Tcl runs the tests and generates +# errors. No output means no errors found. +# +# Copyright (c) 2023 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testencoding [llength [info commands testencoding]] + +# Maps encoded bytes string to utf-8 equivalents, both in hex +# encoding utf-8 encdata +lappend utfExtMap {*}{ + ascii 414243 414243 +} + +# Simple test with basic flags +proc testbasic {direction enc hexin hexout {flags {start end}}} { + if {$direction eq "toutf"} { + set cmd Tcl_ExternalToUtf + } else { + set cmd Tcl_UtfToExternal + } + set in [binary decode hex $hexin] + set out [binary decode hex $hexout] + set dstlen 40 ;# Should be enough for all encoding tests + + # The C wrapper fills entire destination buffer with FF. + # Anything beyond expected output should have FF's + set filler [string repeat \xFF $dstlen] + set result [string range "$out$filler" 0 $dstlen-1] + test $cmd-$enc-$hexin-[join $flags -] "$cmd - $enc - $hexin - $flags" -body \ + [list testencoding $cmd $enc $in $flags {} $dstlen] \ + -result [list ok {} $result] + foreach profile [encoding profiles] { + set flags2 [linsert $flags end profile$profile] + test $cmd-$enc-$hexin-[join $flags2 -] "$cmd - $enc - $hexin - $flags" -body \ + [list testencoding $cmd $enc $in $flags2 {} $dstlen] \ + -result [list ok {} $result] + } +} + +# +# Basic tests +foreach {enc utfhex hex} $utfExtMap { + # Basic test - TCL_ENCODING_START|TCL_ENCODING_END + # Note by default output should be terminated with \0 + testbasic toutf $enc $hex ${utfhex}00 {start end} + testbasic fromutf $enc $utfhex ${hex}00 {start end} + + # Test TCL_ENCODING_NO_TERMINATE + testbasic toutf $enc $hex $utfhex {start end noterminate} + # knownBug - noterminate not obeyed by fromutf + # testbasic fromutf $enc $utfhex $hex {start end noterminate} +} + +# Test for insufficient space +test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body { + testencoding Tcl_UtfToExternal ucs-2 A {start end} {} 1 +} -result [list nospace {} \xFF] + +# Another bug - char limit not obeyed +# % set cv 2 +# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv +# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ + +test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body { + set src \x82\x4f\x82\x50\x82 + lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf + set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] + lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] +} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] + + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/util.test b/tests/util.test index 11ee3fa..c3b9f2d 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,8 +1,8 @@ # 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. @@ -13,13 +13,17 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint controversialNaN 1 testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] +testConstraint testprint [llength [info commands testprint]] + +testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}] + # Big test for correct ordering of data in [expr] @@ -29,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) @@ -41,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) @@ -67,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 @@ -203,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. @@ -238,14 +242,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 @@ -258,15 +262,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 @@ -276,17 +280,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\u008fc] + # 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 @@ -295,13 +299,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 @@ -355,16 +359,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 @@ -387,11 +391,11 @@ 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 -test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -399,7 +403,7 @@ test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} -test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -407,7 +411,7 @@ test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.39999999999} -test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -415,7 +419,7 @@ test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} -test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 5 } -body { @@ -430,7 +434,7 @@ test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr {3.0e98}] } {x3e+98} -test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { +test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 7 @@ -440,7 +444,7 @@ test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {7 7} -test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup { +test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -452,7 +456,7 @@ test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -set } -cleanup { set ::tcl_precision $old_precision } -result {12 6} -test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { +test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -465,7 +469,7 @@ test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { +test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -482,27 +486,27 @@ test util-8.1 {TclNeedSpace - correct utf-8 handling} { # 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" +} "吠 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 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 @@ -574,188 +578,252 @@ test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring { list [llength [testdstring get]] [string index [testdstring get] 9] } {2 \{} -test util-9.0.0 {TclGetIntForIndex} { +test util-9.0.0 {Tcl_GetIntForIndex} { string index abcd 0 } a -test util-9.0.1 {TclGetIntForIndex} { +test util-9.0.1 {Tcl_GetIntForIndex} { string index abcd 0x0 } a -test util-9.0.2 {TclGetIntForIndex} { +test util-9.0.2 {Tcl_GetIntForIndex} { string index abcd -0x0 } a -test util-9.0.3 {TclGetIntForIndex} { +test util-9.0.3 {Tcl_GetIntForIndex} { string index abcd { 0 } } a -test util-9.0.4 {TclGetIntForIndex} { +test util-9.0.4 {Tcl_GetIntForIndex} { string index abcd { 0x0 } } a -test util-9.0.5 {TclGetIntForIndex} { +test util-9.0.5 {Tcl_GetIntForIndex} { string index abcd { -0x0 } } a -test util-9.0.6 {TclGetIntForIndex} { +test util-9.0.6 {Tcl_GetIntForIndex} { string index abcd 01 } b -test util-9.0.7 {TclGetIntForIndex} { +test util-9.0.7 {Tcl_GetIntForIndex} { string index abcd { 01 } } b -test util-9.1.0 {TclGetIntForIndex} { +test util-9.0.8 {Tcl_GetIntForIndex} { + string index abcd { 0d0 } +} a +test util-9.0.9 {Tcl_GetIntForIndex} { + string index abcd { -0d0 } +} a +test util-9.1.0 {Tcl_GetIntForIndex} { string index abcd 3 } d -test util-9.1.1 {TclGetIntForIndex} { +test util-9.1.1 {Tcl_GetIntForIndex} { string index abcd { 3 } } d -test util-9.1.2 {TclGetIntForIndex} { +test util-9.1.2 {Tcl_GetIntForIndex} { string index abcdefghijk 0xa } k -test util-9.1.3 {TclGetIntForIndex} { +test util-9.1.3 {Tcl_GetIntForIndex} { string index abcdefghijk { 0xa } } k -test util-9.2.0 {TclGetIntForIndex} { +test util-9.1.4 {Tcl_GetIntForIndex} { + string index abcdefghijk 0d10 +} k +test util-9.1.5 {Tcl_GetIntForIndex} { + string index abcdefghijk { 0d10 } +} k +test util-9.2.0 {Tcl_GetIntForIndex} { string index abcd end } d -test util-9.2.1 {TclGetIntForIndex} -body { +test util-9.2.1 {Tcl_GetIntForIndex} -body { string index abcd { end} } -returnCodes error -match glob -result * -test util-9.2.2 {TclGetIntForIndex} -body { +test util-9.2.2 {Tcl_GetIntForIndex} -body { string index abcd {end } } -returnCodes error -match glob -result * -test util-9.3 {TclGetIntForIndex} { +test util-9.3 {Tcl_GetIntForIndex} -body { # Deprecated string index abcd en -} d -test util-9.4 {TclGetIntForIndex} { +} -returnCodes error -match glob -result * +test util-9.4 {Tcl_GetIntForIndex} -body { # Deprecated string index abcd e -} d -test util-9.5.0 {TclGetIntForIndex} { +} -returnCodes error -match glob -result * +test util-9.5.0 {Tcl_GetIntForIndex} { string index abcd end-1 } c -test util-9.5.1 {TclGetIntForIndex} { +test util-9.5.1 {Tcl_GetIntForIndex} { string index abcd {end-1 } } c -test util-9.5.2 {TclGetIntForIndex} -body { +test util-9.5.2 {Tcl_GetIntForIndex} -body { string index abcd { end-1} } -returnCodes error -match glob -result * -test util-9.6 {TclGetIntForIndex} { +test util-9.6 {Tcl_GetIntForIndex} { string index abcd end+-1 } c -test util-9.7 {TclGetIntForIndex} { +test util-9.7 {Tcl_GetIntForIndex} { string index abcd end+1 } {} -test util-9.8 {TclGetIntForIndex} { +test util-9.8 {Tcl_GetIntForIndex} { string index abcd end--1 } {} -test util-9.9.0 {TclGetIntForIndex} { +test util-9.9.0 {Tcl_GetIntForIndex} { string index abcd 0+0 } a -test util-9.9.1 {TclGetIntForIndex} { +test util-9.9.1 {Tcl_GetIntForIndex} { string index abcd { 0+0 } } a -test util-9.10 {TclGetIntForIndex} { +test util-9.10 {Tcl_GetIntForIndex} { string index abcd 0-0 } a -test util-9.11 {TclGetIntForIndex} { +test util-9.11 {Tcl_GetIntForIndex} { string index abcd 1+0 } b -test util-9.12 {TclGetIntForIndex} { +test util-9.12 {Tcl_GetIntForIndex} { string index abcd 1-0 } b -test util-9.13 {TclGetIntForIndex} { +test util-9.13 {Tcl_GetIntForIndex} { string index abcd 1+1 } c -test util-9.14 {TclGetIntForIndex} { +test util-9.14 {Tcl_GetIntForIndex} { string index abcd 1-1 } a -test util-9.15 {TclGetIntForIndex} { +test util-9.15 {Tcl_GetIntForIndex} { string index abcd -1+2 } b -test util-9.16 {TclGetIntForIndex} { +test util-9.16 {Tcl_GetIntForIndex} { string index abcd -1--2 } b -test util-9.17 {TclGetIntForIndex} { +test util-9.17 {Tcl_GetIntForIndex} { string index abcd { -1+2 } } b -test util-9.18 {TclGetIntForIndex} { +test util-9.18 {Tcl_GetIntForIndex} { string index abcd { -1--2 } } b -test util-9.19 {TclGetIntForIndex} -body { +test util-9.19 {Tcl_GetIntForIndex} -body { string index a {} } -returnCodes error -match glob -result * -test util-9.20 {TclGetIntForIndex} -body { +test util-9.20 {Tcl_GetIntForIndex} -body { string index a { } } -returnCodes error -match glob -result * -test util-9.21 {TclGetIntForIndex} -body { +test util-9.21 {Tcl_GetIntForIndex} -body { string index a " \r\t\n" } -returnCodes error -match glob -result * -test util-9.22 {TclGetIntForIndex} -body { +test util-9.22 {Tcl_GetIntForIndex} -body { string index a + } -returnCodes error -match glob -result * -test util-9.23 {TclGetIntForIndex} -body { +test util-9.23 {Tcl_GetIntForIndex} -body { string index a - } -returnCodes error -match glob -result * -test util-9.24 {TclGetIntForIndex} -body { +test util-9.24 {Tcl_GetIntForIndex} -body { string index a x } -returnCodes error -match glob -result * -test util-9.25 {TclGetIntForIndex} -body { +test util-9.25 {Tcl_GetIntForIndex} -body { string index a +x } -returnCodes error -match glob -result * -test util-9.26 {TclGetIntForIndex} -body { +test util-9.26 {Tcl_GetIntForIndex} -body { string index a -x } -returnCodes error -match glob -result * -test util-9.27 {TclGetIntForIndex} -body { +test util-9.27 {Tcl_GetIntForIndex} -body { string index a 0y } -returnCodes error -match glob -result * -test util-9.28 {TclGetIntForIndex} -body { +test util-9.28 {Tcl_GetIntForIndex} -body { string index a 1* } -returnCodes error -match glob -result * -test util-9.29 {TclGetIntForIndex} -body { +test util-9.29 {Tcl_GetIntForIndex} -body { string index a 0+ } -returnCodes error -match glob -result * -test util-9.30 {TclGetIntForIndex} -body { +test util-9.30 {Tcl_GetIntForIndex} -body { string index a {0+ } } -returnCodes error -match glob -result * -test util-9.31 {TclGetIntForIndex} -body { +test util-9.31 {Tcl_GetIntForIndex} -body { string index a 0x } -returnCodes error -match glob -result * -test util-9.32 {TclGetIntForIndex} -body { - string index a 0x1FFFFFFFF+0 +test util-9.31.1 {Tcl_GetIntForIndex} -body { + string index a 0d } -returnCodes error -match glob -result * -test util-9.33 {TclGetIntForIndex} -body { +test util-9.32 {Tcl_GetIntForIndex} -body { + string index a 0x1FFFFFFFF+0 +} -result {} +test util-9.33 {Tcl_GetIntForIndex} -body { string index a 100000000000+0 -} -returnCodes error -match glob -result * -test util-9.34 {TclGetIntForIndex} -body { +} -result {} +test util-9.33.1 {Tcl_GetIntForIndex} -body { + string index a 0d100000000000+0 +} -result {} +test util-9.34 {Tcl_GetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * -test util-9.35 {TclGetIntForIndex} -body { +test util-9.35 {Tcl_GetIntForIndex} -body { string index a 1e23 } -returnCodes error -match glob -result * -test util-9.36 {TclGetIntForIndex} -body { +test util-9.36 {Tcl_GetIntForIndex} -body { string index a 1.5e2 } -returnCodes error -match glob -result * -test util-9.37 {TclGetIntForIndex} -body { +test util-9.37 {Tcl_GetIntForIndex} -body { string index a 0+x } -returnCodes error -match glob -result * -test util-9.38 {TclGetIntForIndex} -body { +test util-9.38 {Tcl_GetIntForIndex} -body { string index a 0+0x } -returnCodes error -match glob -result * -test util-9.39 {TclGetIntForIndex} -body { +test util-9.39 {Tcl_GetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * -test util-9.40 {TclGetIntForIndex} -body { +test util-9.40 {Tcl_GetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * -test util-9.41 {TclGetIntForIndex} -body { +test util-9.41 {Tcl_GetIntForIndex} -body { string index a 0+1.0 } -returnCodes error -match glob -result * -test util-9.42 {TclGetIntForIndex} -body { +test util-9.42 {Tcl_GetIntForIndex} -body { string index a 0+1e2 } -returnCodes error -match glob -result * -test util-9.43 {TclGetIntForIndex} -body { +test util-9.43 {Tcl_GetIntForIndex} -body { string index a 0+1.5e1 } -returnCodes error -match glob -result * -test util-9.44 {TclGetIntForIndex} -body { +test util-9.44 {Tcl_GetIntForIndex} -body { string index a 0+1000000000000 +} -result {} +test util-9.45 {Tcl_GetIntForIndex} -body { + string index abcd end+2305843009213693950 +} -result {} +test util-9.46 {Tcl_GetIntForIndex} -body { + string index abcd end+4294967294 +} -result {} +# TIP 502 +test util-9.47 {Tcl_GetIntForIndex} -body { + string index abcd 0x10000000000000000 +} -result {} +test util-9.48 {Tcl_GetIntForIndex} { + string index abcd -0x10000000000000000 +} {} +test util-9.49 {Tcl_GetIntForIndex} -body { + string index abcd end*1 +} -returnCodes error -match glob -result * +test util-9.50 {Tcl_GetIntForIndex} -body { + string index abcd {end- 1} +} -returnCodes error -match glob -result * +test util-9.51 {Tcl_GetIntForIndex} -body { + string index abcd end-end +} -returnCodes error -match glob -result * +test util-9.52 {Tcl_GetIntForIndex} -body { + string index abcd end-x } -returnCodes error -match glob -result * +test util-9.53 {Tcl_GetIntForIndex} -body { + string index abcd end-0.1 +} -returnCodes error -match glob -result * +test util-9.54 {Tcl_GetIntForIndex} { + string index abcd end-0x10000000000000000 +} {} +test util-9.55 {Tcl_GetIntForIndex} -body { + string index abcd end+0x10000000000000000 +} -result {} +test util-9.56 {Tcl_GetIntForIndex} -body { + string index abcd end--0x10000000000000000 +} -result {} +test util-9.57 {Tcl_GetIntForIndex} { + string index abcd end+-0x10000000000000000 +} {} +test util-9.58 {Tcl_GetIntForIndex} -body { + string index abcd end--0x8000000000000000 +} -result {} +test util-9.59 {Tcl_GetIntForIndex} { + string index abcd 0-0x10000000000000000 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 @@ -2165,7 +2233,6 @@ test util-15.8 {smallest normal} {*}{ } } -set saved_precision $::tcl_precision foreach ::tcl_precision {0 12} { for {set e -312} {$e < -9} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ @@ -2179,7 +2246,7 @@ for {set e -9} {$e < -4} {incr e} { } set tcl_precision 12 for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} \ + test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \ "expr {1.1e$e}" 1.1e[format %+03d $e] } foreach ::tcl_precision {0 12} { @@ -2209,1828 +2276,1828 @@ foreach ::tcl_precision {0 12} { } } set tcl_precision 17 -test util-16.1.17.-300 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \ {expr {1e-300}} \ 1e-300 -test util-16.1.17.-299 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \ {expr {1e-299}} \ 9.9999999999999999e-300 -test util-16.1.17.-298 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \ {expr {1e-298}} \ 9.9999999999999991e-299 -test util-16.1.17.-297 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \ {expr {1e-297}} \ 1e-297 -test util-16.1.17.-296 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \ {expr {1e-296}} \ 1e-296 -test util-16.1.17.-295 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \ {expr {1e-295}} \ 1.0000000000000001e-295 -test util-16.1.17.-294 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \ {expr {1e-294}} \ 1e-294 -test util-16.1.17.-293 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \ {expr {1e-293}} \ 1.0000000000000001e-293 -test util-16.1.17.-292 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \ {expr {1e-292}} \ 1.0000000000000001e-292 -test util-16.1.17.-291 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \ {expr {1e-291}} \ 9.9999999999999996e-292 -test util-16.1.17.-290 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \ {expr {1e-290}} \ 1.0000000000000001e-290 -test util-16.1.17.-289 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \ {expr {1e-289}} \ 1e-289 -test util-16.1.17.-288 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \ {expr {1e-288}} \ 1.0000000000000001e-288 -test util-16.1.17.-287 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \ {expr {1e-287}} \ 1e-287 -test util-16.1.17.-286 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \ {expr {1e-286}} \ 1.0000000000000001e-286 -test util-16.1.17.-285 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \ {expr {1e-285}} \ 1.0000000000000001e-285 -test util-16.1.17.-284 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \ {expr {1e-284}} \ 1e-284 -test util-16.1.17.-283 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \ {expr {1e-283}} \ 9.9999999999999995e-284 -test util-16.1.17.-282 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \ {expr {1e-282}} \ 1e-282 -test util-16.1.17.-281 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \ {expr {1e-281}} \ 1e-281 -test util-16.1.17.-280 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \ {expr {1e-280}} \ 9.9999999999999996e-281 -test util-16.1.17.-279 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \ {expr {1e-279}} \ 1.0000000000000001e-279 -test util-16.1.17.-278 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \ {expr {1e-278}} \ 9.9999999999999994e-279 -test util-16.1.17.-277 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \ {expr {1e-277}} \ 9.9999999999999997e-278 -test util-16.1.17.-276 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \ {expr {1e-276}} \ 1.0000000000000001e-276 -test util-16.1.17.-275 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \ {expr {1e-275}} \ 9.9999999999999993e-276 -test util-16.1.17.-274 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \ {expr {1e-274}} \ 9.9999999999999997e-275 -test util-16.1.17.-273 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \ {expr {1e-273}} \ 1.0000000000000001e-273 -test util-16.1.17.-272 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \ {expr {1e-272}} \ 9.9999999999999993e-273 -test util-16.1.17.-271 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \ {expr {1e-271}} \ 9.9999999999999996e-272 -test util-16.1.17.-270 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \ {expr {1e-270}} \ 1e-270 -test util-16.1.17.-269 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \ {expr {1e-269}} \ 9.9999999999999996e-270 -test util-16.1.17.-268 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \ {expr {1e-268}} \ 9.9999999999999996e-269 -test util-16.1.17.-267 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \ {expr {1e-267}} \ 9.9999999999999998e-268 -test util-16.1.17.-266 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \ {expr {1e-266}} \ 9.9999999999999998e-267 -test util-16.1.17.-265 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \ {expr {1e-265}} \ 9.9999999999999998e-266 -test util-16.1.17.-264 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \ {expr {1e-264}} \ 1e-264 -test util-16.1.17.-263 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \ {expr {1e-263}} \ 1e-263 -test util-16.1.17.-262 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \ {expr {1e-262}} \ 1e-262 -test util-16.1.17.-261 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \ {expr {1e-261}} \ 9.9999999999999998e-262 -test util-16.1.17.-260 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \ {expr {1e-260}} \ 9.9999999999999996e-261 -test util-16.1.17.-259 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \ {expr {1e-259}} \ 1.0000000000000001e-259 -test util-16.1.17.-258 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \ {expr {1e-258}} \ 9.9999999999999995e-259 -test util-16.1.17.-257 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \ {expr {1e-257}} \ 9.9999999999999998e-258 -test util-16.1.17.-256 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \ {expr {1e-256}} \ 9.9999999999999998e-257 -test util-16.1.17.-255 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \ {expr {1e-255}} \ 1e-255 -test util-16.1.17.-254 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \ {expr {1e-254}} \ 9.9999999999999991e-255 -test util-16.1.17.-253 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \ {expr {1e-253}} \ 1.0000000000000001e-253 -test util-16.1.17.-252 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \ {expr {1e-252}} \ 9.9999999999999994e-253 -test util-16.1.17.-251 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \ {expr {1e-251}} \ 1e-251 -test util-16.1.17.-250 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \ {expr {1e-250}} \ 1.0000000000000001e-250 -test util-16.1.17.-249 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \ {expr {1e-249}} \ 1.0000000000000001e-249 -test util-16.1.17.-248 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \ {expr {1e-248}} \ 9.9999999999999998e-249 -test util-16.1.17.-247 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \ {expr {1e-247}} \ 1e-247 -test util-16.1.17.-246 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \ {expr {1e-246}} \ 9.9999999999999996e-247 -test util-16.1.17.-245 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \ {expr {1e-245}} \ 9.9999999999999993e-246 -test util-16.1.17.-244 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \ {expr {1e-244}} \ 9.9999999999999993e-245 -test util-16.1.17.-243 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \ {expr {1e-243}} \ 1e-243 -test util-16.1.17.-242 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \ {expr {1e-242}} \ 9.9999999999999997e-243 -test util-16.1.17.-241 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \ {expr {1e-241}} \ 9.9999999999999997e-242 -test util-16.1.17.-240 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \ {expr {1e-240}} \ 9.9999999999999997e-241 -test util-16.1.17.-239 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \ {expr {1e-239}} \ 1.0000000000000001e-239 -test util-16.1.17.-238 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \ {expr {1e-238}} \ 9.9999999999999999e-239 -test util-16.1.17.-237 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \ {expr {1e-237}} \ 9.9999999999999999e-238 -test util-16.1.17.-236 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \ {expr {1e-236}} \ 1e-236 -test util-16.1.17.-235 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \ {expr {1e-235}} \ 9.9999999999999996e-236 -test util-16.1.17.-234 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \ {expr {1e-234}} \ 9.9999999999999996e-235 -test util-16.1.17.-233 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \ {expr {1e-233}} \ 9.9999999999999996e-234 -test util-16.1.17.-232 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \ {expr {1e-232}} \ 1e-232 -test util-16.1.17.-231 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \ {expr {1e-231}} \ 9.9999999999999999e-232 -test util-16.1.17.-230 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \ {expr {1e-230}} \ 1e-230 -test util-16.1.17.-229 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \ {expr {1e-229}} \ 1.0000000000000001e-229 -test util-16.1.17.-228 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \ {expr {1e-228}} \ 1e-228 -test util-16.1.17.-227 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \ {expr {1e-227}} \ 9.9999999999999994e-228 -test util-16.1.17.-226 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \ {expr {1e-226}} \ 9.9999999999999992e-227 -test util-16.1.17.-225 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \ {expr {1e-225}} \ 9.9999999999999996e-226 -test util-16.1.17.-224 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \ {expr {1e-224}} \ 1e-224 -test util-16.1.17.-223 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \ {expr {1e-223}} \ 9.9999999999999997e-224 -test util-16.1.17.-222 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \ {expr {1e-222}} \ 1e-222 -test util-16.1.17.-221 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \ {expr {1e-221}} \ 1e-221 -test util-16.1.17.-220 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \ {expr {1e-220}} \ 9.9999999999999999e-221 -test util-16.1.17.-219 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \ {expr {1e-219}} \ 1e-219 -test util-16.1.17.-218 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \ {expr {1e-218}} \ 1e-218 -test util-16.1.17.-217 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \ {expr {1e-217}} \ 1.0000000000000001e-217 -test util-16.1.17.-216 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \ {expr {1e-216}} \ 1e-216 -test util-16.1.17.-215 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \ {expr {1e-215}} \ 1e-215 -test util-16.1.17.-214 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \ {expr {1e-214}} \ 9.9999999999999991e-215 -test util-16.1.17.-213 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \ {expr {1e-213}} \ 9.9999999999999995e-214 -test util-16.1.17.-212 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \ {expr {1e-212}} \ 9.9999999999999995e-213 -test util-16.1.17.-211 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \ {expr {1e-211}} \ 1.0000000000000001e-211 -test util-16.1.17.-210 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \ {expr {1e-210}} \ 1e-210 -test util-16.1.17.-209 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \ {expr {1e-209}} \ 1e-209 -test util-16.1.17.-208 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \ {expr {1e-208}} \ 1.0000000000000001e-208 -test util-16.1.17.-207 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \ {expr {1e-207}} \ 9.9999999999999993e-208 -test util-16.1.17.-206 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \ {expr {1e-206}} \ 1e-206 -test util-16.1.17.-205 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \ {expr {1e-205}} \ 1e-205 -test util-16.1.17.-204 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \ {expr {1e-204}} \ 1e-204 -test util-16.1.17.-203 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \ {expr {1e-203}} \ 1e-203 -test util-16.1.17.-202 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \ {expr {1e-202}} \ 1e-202 -test util-16.1.17.-201 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \ {expr {1e-201}} \ 9.9999999999999995e-202 -test util-16.1.17.-200 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \ {expr {1e-200}} \ 9.9999999999999998e-201 -test util-16.1.17.-199 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \ {expr {1e-199}} \ 9.9999999999999998e-200 -test util-16.1.17.-198 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \ {expr {1e-198}} \ 9.9999999999999991e-199 -test util-16.1.17.-197 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \ {expr {1e-197}} \ 9.9999999999999999e-198 -test util-16.1.17.-196 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \ {expr {1e-196}} \ 1e-196 -test util-16.1.17.-195 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \ {expr {1e-195}} \ 1.0000000000000001e-195 -test util-16.1.17.-194 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \ {expr {1e-194}} \ 1e-194 -test util-16.1.17.-193 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \ {expr {1e-193}} \ 1e-193 -test util-16.1.17.-192 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \ {expr {1e-192}} \ 1.0000000000000001e-192 -test util-16.1.17.-191 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \ {expr {1e-191}} \ 1e-191 -test util-16.1.17.-190 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \ {expr {1e-190}} \ 1e-190 -test util-16.1.17.-189 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \ {expr {1e-189}} \ 1.0000000000000001e-189 -test util-16.1.17.-188 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \ {expr {1e-188}} \ 9.9999999999999995e-189 -test util-16.1.17.-187 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \ {expr {1e-187}} \ 1e-187 -test util-16.1.17.-186 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \ {expr {1e-186}} \ 9.9999999999999991e-187 -test util-16.1.17.-185 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \ {expr {1e-185}} \ 9.9999999999999999e-186 -test util-16.1.17.-184 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \ {expr {1e-184}} \ 1.0000000000000001e-184 -test util-16.1.17.-183 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \ {expr {1e-183}} \ 1e-183 -test util-16.1.17.-182 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \ {expr {1e-182}} \ 1e-182 -test util-16.1.17.-181 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \ {expr {1e-181}} \ 1e-181 -test util-16.1.17.-180 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \ {expr {1e-180}} \ 1e-180 -test util-16.1.17.-179 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \ {expr {1e-179}} \ 1e-179 -test util-16.1.17.-178 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \ {expr {1e-178}} \ 9.9999999999999995e-179 -test util-16.1.17.-177 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \ {expr {1e-177}} \ 9.9999999999999995e-178 -test util-16.1.17.-176 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \ {expr {1e-176}} \ 1e-176 -test util-16.1.17.-175 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \ {expr {1e-175}} \ 1e-175 -test util-16.1.17.-174 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \ {expr {1e-174}} \ 1e-174 -test util-16.1.17.-173 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \ {expr {1e-173}} \ 1e-173 -test util-16.1.17.-172 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \ {expr {1e-172}} \ 1e-172 -test util-16.1.17.-171 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \ {expr {1e-171}} \ 9.9999999999999998e-172 -test util-16.1.17.-170 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \ {expr {1e-170}} \ 9.9999999999999998e-171 -test util-16.1.17.-169 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \ {expr {1e-169}} \ 1e-169 -test util-16.1.17.-168 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \ {expr {1e-168}} \ 1e-168 -test util-16.1.17.-167 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \ {expr {1e-167}} \ 1e-167 -test util-16.1.17.-166 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \ {expr {1e-166}} \ 1e-166 -test util-16.1.17.-165 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \ {expr {1e-165}} \ 1e-165 -test util-16.1.17.-164 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \ {expr {1e-164}} \ 9.9999999999999996e-165 -test util-16.1.17.-163 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \ {expr {1e-163}} \ 9.9999999999999992e-164 -test util-16.1.17.-162 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \ {expr {1e-162}} \ 9.9999999999999995e-163 -test util-16.1.17.-161 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \ {expr {1e-161}} \ 1e-161 -test util-16.1.17.-160 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \ {expr {1e-160}} \ 9.9999999999999999e-161 -test util-16.1.17.-159 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \ {expr {1e-159}} \ 9.9999999999999999e-160 -test util-16.1.17.-158 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \ {expr {1e-158}} \ 1.0000000000000001e-158 -test util-16.1.17.-157 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \ {expr {1e-157}} \ 9.9999999999999994e-158 -test util-16.1.17.-156 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \ {expr {1e-156}} \ 1e-156 -test util-16.1.17.-155 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \ {expr {1e-155}} \ 1e-155 -test util-16.1.17.-154 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \ {expr {1e-154}} \ 9.9999999999999997e-155 -test util-16.1.17.-153 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \ {expr {1e-153}} \ 1e-153 -test util-16.1.17.-152 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \ {expr {1e-152}} \ 1.0000000000000001e-152 -test util-16.1.17.-151 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \ {expr {1e-151}} \ 9.9999999999999994e-152 -test util-16.1.17.-150 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \ {expr {1e-150}} \ 1e-150 -test util-16.1.17.-149 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \ {expr {1e-149}} \ 9.9999999999999998e-150 -test util-16.1.17.-148 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \ {expr {1e-148}} \ 9.9999999999999994e-149 -test util-16.1.17.-147 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \ {expr {1e-147}} \ 9.9999999999999997e-148 -test util-16.1.17.-146 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \ {expr {1e-146}} \ 1e-146 -test util-16.1.17.-145 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \ {expr {1e-145}} \ 9.9999999999999991e-146 -test util-16.1.17.-144 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \ {expr {1e-144}} \ 9.9999999999999995e-145 -test util-16.1.17.-143 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \ {expr {1e-143}} \ 9.9999999999999995e-144 -test util-16.1.17.-142 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \ {expr {1e-142}} \ 1e-142 -test util-16.1.17.-141 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \ {expr {1e-141}} \ 1e-141 -test util-16.1.17.-140 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \ {expr {1e-140}} \ 9.9999999999999998e-141 -test util-16.1.17.-139 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \ {expr {1e-139}} \ 1e-139 -test util-16.1.17.-138 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \ {expr {1e-138}} \ 1.0000000000000001e-138 -test util-16.1.17.-137 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \ {expr {1e-137}} \ 9.9999999999999998e-138 -test util-16.1.17.-136 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \ {expr {1e-136}} \ 1e-136 -test util-16.1.17.-135 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \ {expr {1e-135}} \ 1e-135 -test util-16.1.17.-134 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \ {expr {1e-134}} \ 1e-134 -test util-16.1.17.-133 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \ {expr {1e-133}} \ 1.0000000000000001e-133 -test util-16.1.17.-132 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \ {expr {1e-132}} \ 9.9999999999999999e-133 -test util-16.1.17.-131 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \ {expr {1e-131}} \ 9.9999999999999999e-132 -test util-16.1.17.-130 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \ {expr {1e-130}} \ 1.0000000000000001e-130 -test util-16.1.17.-129 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \ {expr {1e-129}} \ 9.9999999999999993e-130 -test util-16.1.17.-128 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \ {expr {1e-128}} \ 1.0000000000000001e-128 -test util-16.1.17.-127 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \ {expr {1e-127}} \ 1e-127 -test util-16.1.17.-126 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \ {expr {1e-126}} \ 9.9999999999999995e-127 -test util-16.1.17.-125 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \ {expr {1e-125}} \ 1e-125 -test util-16.1.17.-124 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \ {expr {1e-124}} \ 9.9999999999999993e-125 -test util-16.1.17.-123 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \ {expr {1e-123}} \ 1.0000000000000001e-123 -test util-16.1.17.-122 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \ {expr {1e-122}} \ 1.0000000000000001e-122 -test util-16.1.17.-121 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \ {expr {1e-121}} \ 9.9999999999999998e-122 -test util-16.1.17.-120 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \ {expr {1e-120}} \ 9.9999999999999998e-121 -test util-16.1.17.-119 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \ {expr {1e-119}} \ 1e-119 -test util-16.1.17.-118 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \ {expr {1e-118}} \ 9.9999999999999999e-119 -test util-16.1.17.-117 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \ {expr {1e-117}} \ 1e-117 -test util-16.1.17.-116 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \ {expr {1e-116}} \ 9.9999999999999999e-117 -test util-16.1.17.-115 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \ {expr {1e-115}} \ 1.0000000000000001e-115 -test util-16.1.17.-114 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \ {expr {1e-114}} \ 1.0000000000000001e-114 -test util-16.1.17.-113 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \ {expr {1e-113}} \ 9.9999999999999998e-114 -test util-16.1.17.-112 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \ {expr {1e-112}} \ 9.9999999999999995e-113 -test util-16.1.17.-111 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \ {expr {1e-111}} \ 1.0000000000000001e-111 -test util-16.1.17.-110 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \ {expr {1e-110}} \ 1.0000000000000001e-110 -test util-16.1.17.-109 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \ {expr {1e-109}} \ 9.9999999999999999e-110 -test util-16.1.17.-108 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \ {expr {1e-108}} \ 1e-108 -test util-16.1.17.-107 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \ {expr {1e-107}} \ 1e-107 -test util-16.1.17.-106 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \ {expr {1e-106}} \ 9.9999999999999994e-107 -test util-16.1.17.-105 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \ {expr {1e-105}} \ 9.9999999999999997e-106 -test util-16.1.17.-104 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \ {expr {1e-104}} \ 9.9999999999999993e-105 -test util-16.1.17.-103 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \ {expr {1e-103}} \ 9.9999999999999996e-104 -test util-16.1.17.-102 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \ {expr {1e-102}} \ 9.9999999999999993e-103 -test util-16.1.17.-101 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \ {expr {1e-101}} \ 1.0000000000000001e-101 -test util-16.1.17.-100 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \ {expr {1e-100}} \ 1e-100 -test util-16.1.17.-99 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \ {expr {1e-99}} \ 1e-99 -test util-16.1.17.-98 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \ {expr {1e-98}} \ 9.9999999999999994e-99 -test util-16.1.17.-97 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \ {expr {1e-97}} \ 1e-97 -test util-16.1.17.-96 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \ {expr {1e-96}} \ 9.9999999999999991e-97 -test util-16.1.17.-95 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \ {expr {1e-95}} \ 9.9999999999999999e-96 -test util-16.1.17.-94 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \ {expr {1e-94}} \ 9.9999999999999996e-95 -test util-16.1.17.-93 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \ {expr {1e-93}} \ 9.999999999999999e-94 -test util-16.1.17.-92 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \ {expr {1e-92}} \ 9.9999999999999999e-93 -test util-16.1.17.-91 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \ {expr {1e-91}} \ 1e-91 -test util-16.1.17.-90 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \ {expr {1e-90}} \ 9.9999999999999999e-91 -test util-16.1.17.-89 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \ {expr {1e-89}} \ 1e-89 -test util-16.1.17.-88 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \ {expr {1e-88}} \ 9.9999999999999993e-89 -test util-16.1.17.-87 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \ {expr {1e-87}} \ 1e-87 -test util-16.1.17.-86 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \ {expr {1e-86}} \ 1.0000000000000001e-86 -test util-16.1.17.-85 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \ {expr {1e-85}} \ 9.9999999999999998e-86 -test util-16.1.17.-84 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \ {expr {1e-84}} \ 1e-84 -test util-16.1.17.-83 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \ {expr {1e-83}} \ 1e-83 -test util-16.1.17.-82 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \ {expr {1e-82}} \ 9.9999999999999996e-83 -test util-16.1.17.-81 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \ {expr {1e-81}} \ 9.9999999999999996e-82 -test util-16.1.17.-80 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \ {expr {1e-80}} \ 9.9999999999999996e-81 -test util-16.1.17.-79 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \ {expr {1e-79}} \ 1e-79 -test util-16.1.17.-78 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \ {expr {1e-78}} \ 1e-78 -test util-16.1.17.-77 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \ {expr {1e-77}} \ 9.9999999999999993e-78 -test util-16.1.17.-76 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \ {expr {1e-76}} \ 9.9999999999999993e-77 -test util-16.1.17.-75 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \ {expr {1e-75}} \ 9.9999999999999996e-76 -test util-16.1.17.-74 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \ {expr {1e-74}} \ 9.9999999999999996e-75 -test util-16.1.17.-73 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \ {expr {1e-73}} \ 1e-73 -test util-16.1.17.-72 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \ {expr {1e-72}} \ 9.9999999999999997e-73 -test util-16.1.17.-71 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \ {expr {1e-71}} \ 9.9999999999999992e-72 -test util-16.1.17.-70 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \ {expr {1e-70}} \ 1e-70 -test util-16.1.17.-69 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \ {expr {1e-69}} \ 9.9999999999999996e-70 -test util-16.1.17.-68 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \ {expr {1e-68}} \ 1.0000000000000001e-68 -test util-16.1.17.-67 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \ {expr {1e-67}} \ 9.9999999999999994e-68 -test util-16.1.17.-66 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \ {expr {1e-66}} \ 9.9999999999999998e-67 -test util-16.1.17.-65 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \ {expr {1e-65}} \ 9.9999999999999992e-66 -test util-16.1.17.-64 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \ {expr {1e-64}} \ 9.9999999999999997e-65 -test util-16.1.17.-63 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \ {expr {1e-63}} \ 1.0000000000000001e-63 -test util-16.1.17.-62 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \ {expr {1e-62}} \ 1e-62 -test util-16.1.17.-61 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \ {expr {1e-61}} \ 1e-61 -test util-16.1.17.-60 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \ {expr {1e-60}} \ 9.9999999999999997e-61 -test util-16.1.17.-59 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \ {expr {1e-59}} \ 1e-59 -test util-16.1.17.-58 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \ {expr {1e-58}} \ 1e-58 -test util-16.1.17.-57 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \ {expr {1e-57}} \ 9.9999999999999995e-58 -test util-16.1.17.-56 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \ {expr {1e-56}} \ 1e-56 -test util-16.1.17.-55 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \ {expr {1e-55}} \ 9.9999999999999999e-56 -test util-16.1.17.-54 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \ {expr {1e-54}} \ 1e-54 -test util-16.1.17.-53 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \ {expr {1e-53}} \ 1e-53 -test util-16.1.17.-52 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \ {expr {1e-52}} \ 1e-52 -test util-16.1.17.-51 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \ {expr {1e-51}} \ 1e-51 -test util-16.1.17.-50 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \ {expr {1e-50}} \ 1e-50 -test util-16.1.17.-49 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \ {expr {1e-49}} \ 9.9999999999999994e-50 -test util-16.1.17.-48 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \ {expr {1e-48}} \ 9.9999999999999997e-49 -test util-16.1.17.-47 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \ {expr {1e-47}} \ 9.9999999999999997e-48 -test util-16.1.17.-46 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \ {expr {1e-46}} \ 1e-46 -test util-16.1.17.-45 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \ {expr {1e-45}} \ 9.9999999999999998e-46 -test util-16.1.17.-44 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \ {expr {1e-44}} \ 9.9999999999999995e-45 -test util-16.1.17.-43 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \ {expr {1e-43}} \ 1.0000000000000001e-43 -test util-16.1.17.-42 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \ {expr {1e-42}} \ 1e-42 -test util-16.1.17.-41 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \ {expr {1e-41}} \ 1e-41 -test util-16.1.17.-40 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \ {expr {1e-40}} \ 9.9999999999999993e-41 -test util-16.1.17.-39 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \ {expr {1e-39}} \ 9.9999999999999993e-40 -test util-16.1.17.-38 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \ {expr {1e-38}} \ 9.9999999999999996e-39 -test util-16.1.17.-37 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \ {expr {1e-37}} \ 1.0000000000000001e-37 -test util-16.1.17.-36 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \ {expr {1e-36}} \ 9.9999999999999994e-37 -test util-16.1.17.-35 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \ {expr {1e-35}} \ 1e-35 -test util-16.1.17.-34 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \ {expr {1e-34}} \ 9.9999999999999993e-35 -test util-16.1.17.-33 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \ {expr {1e-33}} \ 1.0000000000000001e-33 -test util-16.1.17.-32 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \ {expr {1e-32}} \ 1.0000000000000001e-32 -test util-16.1.17.-31 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \ {expr {1e-31}} \ 1.0000000000000001e-31 -test util-16.1.17.-30 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \ {expr {1e-30}} \ 1.0000000000000001e-30 -test util-16.1.17.-29 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \ {expr {1e-29}} \ 9.9999999999999994e-30 -test util-16.1.17.-28 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \ {expr {1e-28}} \ 9.9999999999999997e-29 -test util-16.1.17.-27 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \ {expr {1e-27}} \ 1e-27 -test util-16.1.17.-26 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \ {expr {1e-26}} \ 1e-26 -test util-16.1.17.-25 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \ {expr {1e-25}} \ 1e-25 -test util-16.1.17.-24 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \ {expr {1e-24}} \ 9.9999999999999992e-25 -test util-16.1.17.-23 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \ {expr {1e-23}} \ 9.9999999999999996e-24 -test util-16.1.17.-22 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \ {expr {1e-22}} \ 1e-22 -test util-16.1.17.-21 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \ {expr {1e-21}} \ 9.9999999999999991e-22 -test util-16.1.17.-20 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \ {expr {1e-20}} \ 9.9999999999999995e-21 -test util-16.1.17.-19 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \ {expr {1e-19}} \ 9.9999999999999998e-20 -test util-16.1.17.-18 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \ {expr {1e-18}} \ 1.0000000000000001e-18 -test util-16.1.17.-17 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \ {expr {1e-17}} \ 1.0000000000000001e-17 -test util-16.1.17.-16 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \ {expr {1e-16}} \ 9.9999999999999998e-17 -test util-16.1.17.-15 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \ {expr {1e-15}} \ 1.0000000000000001e-15 -test util-16.1.17.-14 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \ {expr {1e-14}} \ 1e-14 -test util-16.1.17.-13 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \ {expr {1e-13}} \ 1e-13 -test util-16.1.17.-12 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \ {expr {1e-12}} \ 9.9999999999999998e-13 -test util-16.1.17.-11 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \ {expr {1e-11}} \ 9.9999999999999994e-12 -test util-16.1.17.-10 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \ {expr {1e-10}} \ 1e-10 -test util-16.1.17.-9 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \ {expr {1e-9}} \ 1.0000000000000001e-09 -test util-16.1.17.-8 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \ {expr {1e-8}} \ 1e-08 -test util-16.1.17.-7 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \ {expr {1e-7}} \ 9.9999999999999995e-08 -test util-16.1.17.-6 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \ {expr {1e-6}} \ 9.9999999999999995e-07 -test util-16.1.17.-5 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \ {expr {1e-5}} \ 1.0000000000000001e-05 -test util-16.1.17.-4 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \ {expr {1e-4}} \ 0.0001 -test util-16.1.17.-3 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \ {expr {1e-3}} \ 0.001 -test util-16.1.17.-2 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \ {expr {1e-2}} \ 0.01 -test util-16.1.17.-1 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \ {expr {1e-1}} \ 0.10000000000000001 -test util-16.1.17.0 {8.4 compatible formatting of doubles} \ +test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \ {expr {1e0}} \ 1.0 -test util-16.1.17.1 {8.4 compatible formatting of doubles} \ +test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \ {expr {1e1}} \ 10.0 -test util-16.1.17.2 {8.4 compatible formatting of doubles} \ +test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \ {expr {1e2}} \ 100.0 -test util-16.1.17.3 {8.4 compatible formatting of doubles} \ +test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \ {expr {1e3}} \ 1000.0 -test util-16.1.17.4 {8.4 compatible formatting of doubles} \ +test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \ {expr {1e4}} \ 10000.0 -test util-16.1.17.5 {8.4 compatible formatting of doubles} \ +test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \ {expr {1e5}} \ 100000.0 -test util-16.1.17.6 {8.4 compatible formatting of doubles} \ +test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \ {expr {1e6}} \ 1000000.0 -test util-16.1.17.7 {8.4 compatible formatting of doubles} \ +test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \ {expr {1e7}} \ 10000000.0 -test util-16.1.17.8 {8.4 compatible formatting of doubles} \ +test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \ {expr {1e8}} \ 100000000.0 -test util-16.1.17.9 {8.4 compatible formatting of doubles} \ +test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \ {expr {1e9}} \ 1000000000.0 -test util-16.1.17.10 {8.4 compatible formatting of doubles} \ +test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \ {expr {1e10}} \ 10000000000.0 -test util-16.1.17.11 {8.4 compatible formatting of doubles} \ +test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \ {expr {1e11}} \ 100000000000.0 -test util-16.1.17.12 {8.4 compatible formatting of doubles} \ +test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \ {expr {1e12}} \ 1000000000000.0 -test util-16.1.17.13 {8.4 compatible formatting of doubles} \ +test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \ {expr {1e13}} \ 10000000000000.0 -test util-16.1.17.14 {8.4 compatible formatting of doubles} \ +test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \ {expr {1e14}} \ 100000000000000.0 -test util-16.1.17.15 {8.4 compatible formatting of doubles} \ +test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \ {expr {1e15}} \ 1000000000000000.0 -test util-16.1.17.16 {8.4 compatible formatting of doubles} \ +test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \ {expr {1e16}} \ 10000000000000000.0 -test util-16.1.17.17 {8.4 compatible formatting of doubles} \ +test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \ {expr {1e17}} \ 1e+17 -test util-16.1.17.18 {8.4 compatible formatting of doubles} \ +test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \ {expr {1e18}} \ 1e+18 -test util-16.1.17.19 {8.4 compatible formatting of doubles} \ +test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \ {expr {1e19}} \ 1e+19 -test util-16.1.17.20 {8.4 compatible formatting of doubles} \ +test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \ {expr {1e20}} \ 1e+20 -test util-16.1.17.21 {8.4 compatible formatting of doubles} \ +test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \ {expr {1e21}} \ 1e+21 -test util-16.1.17.22 {8.4 compatible formatting of doubles} \ +test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \ {expr {1e22}} \ 1e+22 -test util-16.1.17.23 {8.4 compatible formatting of doubles} \ +test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \ {expr {1e23}} \ 9.9999999999999992e+22 -test util-16.1.17.24 {8.4 compatible formatting of doubles} \ +test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \ {expr {1e24}} \ 9.9999999999999998e+23 -test util-16.1.17.25 {8.4 compatible formatting of doubles} \ +test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \ {expr {1e25}} \ 1.0000000000000001e+25 -test util-16.1.17.26 {8.4 compatible formatting of doubles} \ +test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \ {expr {1e26}} \ 1e+26 -test util-16.1.17.27 {8.4 compatible formatting of doubles} \ +test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \ {expr {1e27}} \ 1e+27 -test util-16.1.17.28 {8.4 compatible formatting of doubles} \ +test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \ {expr {1e28}} \ 9.9999999999999996e+27 -test util-16.1.17.29 {8.4 compatible formatting of doubles} \ +test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \ {expr {1e29}} \ 9.9999999999999991e+28 -test util-16.1.17.30 {8.4 compatible formatting of doubles} \ +test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \ {expr {1e30}} \ 1e+30 -test util-16.1.17.31 {8.4 compatible formatting of doubles} \ +test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \ {expr {1e31}} \ 9.9999999999999996e+30 -test util-16.1.17.32 {8.4 compatible formatting of doubles} \ +test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \ {expr {1e32}} \ 1.0000000000000001e+32 -test util-16.1.17.33 {8.4 compatible formatting of doubles} \ +test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \ {expr {1e33}} \ 9.9999999999999995e+32 -test util-16.1.17.34 {8.4 compatible formatting of doubles} \ +test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \ {expr {1e34}} \ 9.9999999999999995e+33 -test util-16.1.17.35 {8.4 compatible formatting of doubles} \ +test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \ {expr {1e35}} \ 9.9999999999999997e+34 -test util-16.1.17.36 {8.4 compatible formatting of doubles} \ +test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \ {expr {1e36}} \ 1e+36 -test util-16.1.17.37 {8.4 compatible formatting of doubles} \ +test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \ {expr {1e37}} \ 9.9999999999999995e+36 -test util-16.1.17.38 {8.4 compatible formatting of doubles} \ +test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \ {expr {1e38}} \ 9.9999999999999998e+37 -test util-16.1.17.39 {8.4 compatible formatting of doubles} \ +test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \ {expr {1e39}} \ 9.9999999999999994e+38 -test util-16.1.17.40 {8.4 compatible formatting of doubles} \ +test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \ {expr {1e40}} \ 1e+40 -test util-16.1.17.41 {8.4 compatible formatting of doubles} \ +test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \ {expr {1e41}} \ 1e+41 -test util-16.1.17.42 {8.4 compatible formatting of doubles} \ +test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \ {expr {1e42}} \ 1e+42 -test util-16.1.17.43 {8.4 compatible formatting of doubles} \ +test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \ {expr {1e43}} \ 1e+43 -test util-16.1.17.44 {8.4 compatible formatting of doubles} \ +test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \ {expr {1e44}} \ 1.0000000000000001e+44 -test util-16.1.17.45 {8.4 compatible formatting of doubles} \ +test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \ {expr {1e45}} \ 9.9999999999999993e+44 -test util-16.1.17.46 {8.4 compatible formatting of doubles} \ +test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \ {expr {1e46}} \ 9.9999999999999999e+45 -test util-16.1.17.47 {8.4 compatible formatting of doubles} \ +test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \ {expr {1e47}} \ 1e+47 -test util-16.1.17.48 {8.4 compatible formatting of doubles} \ +test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \ {expr {1e48}} \ 1e+48 -test util-16.1.17.49 {8.4 compatible formatting of doubles} \ +test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \ {expr {1e49}} \ 9.9999999999999995e+48 -test util-16.1.17.50 {8.4 compatible formatting of doubles} \ +test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \ {expr {1e50}} \ 1.0000000000000001e+50 -test util-16.1.17.51 {8.4 compatible formatting of doubles} \ +test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \ {expr {1e51}} \ 9.9999999999999999e+50 -test util-16.1.17.52 {8.4 compatible formatting of doubles} \ +test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \ {expr {1e52}} \ 9.9999999999999999e+51 -test util-16.1.17.53 {8.4 compatible formatting of doubles} \ +test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \ {expr {1e53}} \ 9.9999999999999999e+52 -test util-16.1.17.54 {8.4 compatible formatting of doubles} \ +test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \ {expr {1e54}} \ 1.0000000000000001e+54 -test util-16.1.17.55 {8.4 compatible formatting of doubles} \ +test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \ {expr {1e55}} \ 1e+55 -test util-16.1.17.56 {8.4 compatible formatting of doubles} \ +test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \ {expr {1e56}} \ 1.0000000000000001e+56 -test util-16.1.17.57 {8.4 compatible formatting of doubles} \ +test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \ {expr {1e57}} \ 1e+57 -test util-16.1.17.58 {8.4 compatible formatting of doubles} \ +test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \ {expr {1e58}} \ 9.9999999999999994e+57 -test util-16.1.17.59 {8.4 compatible formatting of doubles} \ +test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \ {expr {1e59}} \ 9.9999999999999997e+58 -test util-16.1.17.60 {8.4 compatible formatting of doubles} \ +test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \ {expr {1e60}} \ 9.9999999999999995e+59 -test util-16.1.17.61 {8.4 compatible formatting of doubles} \ +test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \ {expr {1e61}} \ 9.9999999999999995e+60 -test util-16.1.17.62 {8.4 compatible formatting of doubles} \ +test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \ {expr {1e62}} \ 1e+62 -test util-16.1.17.63 {8.4 compatible formatting of doubles} \ +test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \ {expr {1e63}} \ 1.0000000000000001e+63 -test util-16.1.17.64 {8.4 compatible formatting of doubles} \ +test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \ {expr {1e64}} \ 1e+64 -test util-16.1.17.65 {8.4 compatible formatting of doubles} \ +test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \ {expr {1e65}} \ 9.9999999999999999e+64 -test util-16.1.17.66 {8.4 compatible formatting of doubles} \ +test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \ {expr {1e66}} \ 9.9999999999999995e+65 -test util-16.1.17.67 {8.4 compatible formatting of doubles} \ +test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \ {expr {1e67}} \ 9.9999999999999998e+66 -test util-16.1.17.68 {8.4 compatible formatting of doubles} \ +test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \ {expr {1e68}} \ 9.9999999999999995e+67 -test util-16.1.17.69 {8.4 compatible formatting of doubles} \ +test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \ {expr {1e69}} \ 1.0000000000000001e+69 -test util-16.1.17.70 {8.4 compatible formatting of doubles} \ +test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \ {expr {1e70}} \ 1.0000000000000001e+70 -test util-16.1.17.71 {8.4 compatible formatting of doubles} \ +test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \ {expr {1e71}} \ 1e+71 -test util-16.1.17.72 {8.4 compatible formatting of doubles} \ +test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \ {expr {1e72}} \ 9.9999999999999994e+71 -test util-16.1.17.73 {8.4 compatible formatting of doubles} \ +test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \ {expr {1e73}} \ 9.9999999999999998e+72 -test util-16.1.17.74 {8.4 compatible formatting of doubles} \ +test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \ {expr {1e74}} \ 9.9999999999999995e+73 -test util-16.1.17.75 {8.4 compatible formatting of doubles} \ +test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \ {expr {1e75}} \ 9.9999999999999993e+74 -test util-16.1.17.76 {8.4 compatible formatting of doubles} \ +test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \ {expr {1e76}} \ 1e+76 -test util-16.1.17.77 {8.4 compatible formatting of doubles} \ +test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \ {expr {1e77}} \ 9.9999999999999998e+76 -test util-16.1.17.78 {8.4 compatible formatting of doubles} \ +test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \ {expr {1e78}} \ 1e+78 -test util-16.1.17.79 {8.4 compatible formatting of doubles} \ +test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \ {expr {1e79}} \ 9.9999999999999997e+78 -test util-16.1.17.80 {8.4 compatible formatting of doubles} \ +test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \ {expr {1e80}} \ 1e+80 -test util-16.1.17.81 {8.4 compatible formatting of doubles} \ +test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \ {expr {1e81}} \ 9.9999999999999992e+80 -test util-16.1.17.82 {8.4 compatible formatting of doubles} \ +test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \ {expr {1e82}} \ 9.9999999999999996e+81 -test util-16.1.17.83 {8.4 compatible formatting of doubles} \ +test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \ {expr {1e83}} \ 1e+83 -test util-16.1.17.84 {8.4 compatible formatting of doubles} \ +test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \ {expr {1e84}} \ 1.0000000000000001e+84 -test util-16.1.17.85 {8.4 compatible formatting of doubles} \ +test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \ {expr {1e85}} \ 1e+85 -test util-16.1.17.86 {8.4 compatible formatting of doubles} \ +test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \ {expr {1e86}} \ 1e+86 -test util-16.1.17.87 {8.4 compatible formatting of doubles} \ +test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \ {expr {1e87}} \ 9.9999999999999996e+86 -test util-16.1.17.88 {8.4 compatible formatting of doubles} \ +test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \ {expr {1e88}} \ 9.9999999999999996e+87 -test util-16.1.17.89 {8.4 compatible formatting of doubles} \ +test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \ {expr {1e89}} \ 9.9999999999999999e+88 -test util-16.1.17.90 {8.4 compatible formatting of doubles} \ +test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \ {expr {1e90}} \ 9.9999999999999997e+89 -test util-16.1.17.91 {8.4 compatible formatting of doubles} \ +test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \ {expr {1e91}} \ 1.0000000000000001e+91 -test util-16.1.17.92 {8.4 compatible formatting of doubles} \ +test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \ {expr {1e92}} \ 1e+92 -test util-16.1.17.93 {8.4 compatible formatting of doubles} \ +test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \ {expr {1e93}} \ 1e+93 -test util-16.1.17.94 {8.4 compatible formatting of doubles} \ +test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \ {expr {1e94}} \ 1e+94 -test util-16.1.17.95 {8.4 compatible formatting of doubles} \ +test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \ {expr {1e95}} \ 1e+95 -test util-16.1.17.96 {8.4 compatible formatting of doubles} \ +test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \ {expr {1e96}} \ 1e+96 -test util-16.1.17.97 {8.4 compatible formatting of doubles} \ +test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \ {expr {1e97}} \ 1.0000000000000001e+97 -test util-16.1.17.98 {8.4 compatible formatting of doubles} \ +test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \ {expr {1e98}} \ 1e+98 -test util-16.1.17.99 {8.4 compatible formatting of doubles} \ +test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \ {expr {1e99}} \ 9.9999999999999997e+98 -test util-16.1.17.100 {8.4 compatible formatting of doubles} \ +test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \ {expr {1e100}} \ 1e+100 -test util-16.1.17.101 {8.4 compatible formatting of doubles} \ +test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \ {expr {1e101}} \ 9.9999999999999998e+100 -test util-16.1.17.102 {8.4 compatible formatting of doubles} \ +test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \ {expr {1e102}} \ 9.9999999999999998e+101 -test util-16.1.17.103 {8.4 compatible formatting of doubles} \ +test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \ {expr {1e103}} \ 1e+103 -test util-16.1.17.104 {8.4 compatible formatting of doubles} \ +test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \ {expr {1e104}} \ 1e+104 -test util-16.1.17.105 {8.4 compatible formatting of doubles} \ +test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \ {expr {1e105}} \ 9.9999999999999994e+104 -test util-16.1.17.106 {8.4 compatible formatting of doubles} \ +test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \ {expr {1e106}} \ 1.0000000000000001e+106 -test util-16.1.17.107 {8.4 compatible formatting of doubles} \ +test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \ {expr {1e107}} \ 9.9999999999999997e+106 -test util-16.1.17.108 {8.4 compatible formatting of doubles} \ +test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \ {expr {1e108}} \ 1e+108 -test util-16.1.17.109 {8.4 compatible formatting of doubles} \ +test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \ {expr {1e109}} \ 9.9999999999999998e+108 -test util-16.1.17.110 {8.4 compatible formatting of doubles} \ +test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \ {expr {1e110}} \ 1e+110 -test util-16.1.17.111 {8.4 compatible formatting of doubles} \ +test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \ {expr {1e111}} \ 9.9999999999999996e+110 -test util-16.1.17.112 {8.4 compatible formatting of doubles} \ +test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \ {expr {1e112}} \ 9.9999999999999993e+111 -test util-16.1.17.113 {8.4 compatible formatting of doubles} \ +test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \ {expr {1e113}} \ 1e+113 -test util-16.1.17.114 {8.4 compatible formatting of doubles} \ +test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \ {expr {1e114}} \ 1e+114 -test util-16.1.17.115 {8.4 compatible formatting of doubles} \ +test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \ {expr {1e115}} \ 1e+115 -test util-16.1.17.116 {8.4 compatible formatting of doubles} \ +test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \ {expr {1e116}} \ 1e+116 -test util-16.1.17.117 {8.4 compatible formatting of doubles} \ +test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \ {expr {1e117}} \ 1.0000000000000001e+117 -test util-16.1.17.118 {8.4 compatible formatting of doubles} \ +test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \ {expr {1e118}} \ 9.9999999999999997e+117 -test util-16.1.17.119 {8.4 compatible formatting of doubles} \ +test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \ {expr {1e119}} \ 9.9999999999999994e+118 -test util-16.1.17.120 {8.4 compatible formatting of doubles} \ +test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \ {expr {1e120}} \ 9.9999999999999998e+119 -test util-16.1.17.121 {8.4 compatible formatting of doubles} \ +test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \ {expr {1e121}} \ 1e+121 -test util-16.1.17.122 {8.4 compatible formatting of doubles} \ +test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \ {expr {1e122}} \ 1e+122 -test util-16.1.17.123 {8.4 compatible formatting of doubles} \ +test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \ {expr {1e123}} \ 9.9999999999999998e+122 -test util-16.1.17.124 {8.4 compatible formatting of doubles} \ +test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \ {expr {1e124}} \ 9.9999999999999995e+123 -test util-16.1.17.125 {8.4 compatible formatting of doubles} \ +test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \ {expr {1e125}} \ 9.9999999999999992e+124 -test util-16.1.17.126 {8.4 compatible formatting of doubles} \ +test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \ {expr {1e126}} \ 9.9999999999999992e+125 -test util-16.1.17.127 {8.4 compatible formatting of doubles} \ +test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \ {expr {1e127}} \ 9.9999999999999995e+126 -test util-16.1.17.128 {8.4 compatible formatting of doubles} \ +test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \ {expr {1e128}} \ 1.0000000000000001e+128 -test util-16.1.17.129 {8.4 compatible formatting of doubles} \ +test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \ {expr {1e129}} \ 1e+129 -test util-16.1.17.130 {8.4 compatible formatting of doubles} \ +test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \ {expr {1e130}} \ 1.0000000000000001e+130 -test util-16.1.17.131 {8.4 compatible formatting of doubles} \ +test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \ {expr {1e131}} \ 9.9999999999999991e+130 -test util-16.1.17.132 {8.4 compatible formatting of doubles} \ +test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \ {expr {1e132}} \ 9.9999999999999999e+131 -test util-16.1.17.133 {8.4 compatible formatting of doubles} \ +test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \ {expr {1e133}} \ 1e+133 -test util-16.1.17.134 {8.4 compatible formatting of doubles} \ +test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \ {expr {1e134}} \ 9.9999999999999992e+133 -test util-16.1.17.135 {8.4 compatible formatting of doubles} \ +test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \ {expr {1e135}} \ 9.9999999999999996e+134 -test util-16.1.17.136 {8.4 compatible formatting of doubles} \ +test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \ {expr {1e136}} \ 1.0000000000000001e+136 -test util-16.1.17.137 {8.4 compatible formatting of doubles} \ +test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \ {expr {1e137}} \ 1e+137 -test util-16.1.17.138 {8.4 compatible formatting of doubles} \ +test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \ {expr {1e138}} \ 1e+138 -test util-16.1.17.139 {8.4 compatible formatting of doubles} \ +test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \ {expr {1e139}} \ 1e+139 -test util-16.1.17.140 {8.4 compatible formatting of doubles} \ +test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \ {expr {1e140}} \ 1.0000000000000001e+140 -test util-16.1.17.141 {8.4 compatible formatting of doubles} \ +test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \ {expr {1e141}} \ 1e+141 -test util-16.1.17.142 {8.4 compatible formatting of doubles} \ +test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \ {expr {1e142}} \ 1.0000000000000001e+142 -test util-16.1.17.143 {8.4 compatible formatting of doubles} \ +test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \ {expr {1e143}} \ 1e+143 -test util-16.1.17.144 {8.4 compatible formatting of doubles} \ +test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \ {expr {1e144}} \ 1e+144 -test util-16.1.17.145 {8.4 compatible formatting of doubles} \ +test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \ {expr {1e145}} \ 9.9999999999999999e+144 -test util-16.1.17.146 {8.4 compatible formatting of doubles} \ +test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \ {expr {1e146}} \ 9.9999999999999993e+145 -test util-16.1.17.147 {8.4 compatible formatting of doubles} \ +test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \ {expr {1e147}} \ 9.9999999999999998e+146 -test util-16.1.17.148 {8.4 compatible formatting of doubles} \ +test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \ {expr {1e148}} \ 1e+148 -test util-16.1.17.149 {8.4 compatible formatting of doubles} \ +test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \ {expr {1e149}} \ 1e+149 -test util-16.1.17.150 {8.4 compatible formatting of doubles} \ +test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \ {expr {1e150}} \ 9.9999999999999998e+149 -test util-16.1.17.151 {8.4 compatible formatting of doubles} \ +test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \ {expr {1e151}} \ 1e+151 -test util-16.1.17.152 {8.4 compatible formatting of doubles} \ +test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \ {expr {1e152}} \ 1e+152 -test util-16.1.17.153 {8.4 compatible formatting of doubles} \ +test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \ {expr {1e153}} \ 1e+153 -test util-16.1.17.154 {8.4 compatible formatting of doubles} \ +test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \ {expr {1e154}} \ 1e+154 -test util-16.1.17.155 {8.4 compatible formatting of doubles} \ +test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \ {expr {1e155}} \ 1e+155 -test util-16.1.17.156 {8.4 compatible formatting of doubles} \ +test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \ {expr {1e156}} \ 9.9999999999999998e+155 -test util-16.1.17.157 {8.4 compatible formatting of doubles} \ +test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \ {expr {1e157}} \ 9.9999999999999998e+156 -test util-16.1.17.158 {8.4 compatible formatting of doubles} \ +test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \ {expr {1e158}} \ 9.9999999999999995e+157 -test util-16.1.17.159 {8.4 compatible formatting of doubles} \ +test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \ {expr {1e159}} \ 9.9999999999999993e+158 -test util-16.1.17.160 {8.4 compatible formatting of doubles} \ +test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \ {expr {1e160}} \ 1e+160 -test util-16.1.17.161 {8.4 compatible formatting of doubles} \ +test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \ {expr {1e161}} \ 1e+161 -test util-16.1.17.162 {8.4 compatible formatting of doubles} \ +test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \ {expr {1e162}} \ 9.9999999999999994e+161 -test util-16.1.17.163 {8.4 compatible formatting of doubles} \ +test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \ {expr {1e163}} \ 9.9999999999999994e+162 -test util-16.1.17.164 {8.4 compatible formatting of doubles} \ +test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \ {expr {1e164}} \ 1e+164 -test util-16.1.17.165 {8.4 compatible formatting of doubles} \ +test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \ {expr {1e165}} \ 9.999999999999999e+164 -test util-16.1.17.166 {8.4 compatible formatting of doubles} \ +test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \ {expr {1e166}} \ 9.9999999999999994e+165 -test util-16.1.17.167 {8.4 compatible formatting of doubles} \ +test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \ {expr {1e167}} \ 1e+167 -test util-16.1.17.168 {8.4 compatible formatting of doubles} \ +test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \ {expr {1e168}} \ 9.9999999999999993e+167 -test util-16.1.17.169 {8.4 compatible formatting of doubles} \ +test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \ {expr {1e169}} \ 9.9999999999999993e+168 -test util-16.1.17.170 {8.4 compatible formatting of doubles} \ +test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \ {expr {1e170}} \ 1e+170 -test util-16.1.17.171 {8.4 compatible formatting of doubles} \ +test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \ {expr {1e171}} \ 9.9999999999999995e+170 -test util-16.1.17.172 {8.4 compatible formatting of doubles} \ +test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \ {expr {1e172}} \ 1.0000000000000001e+172 -test util-16.1.17.173 {8.4 compatible formatting of doubles} \ +test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \ {expr {1e173}} \ 1e+173 -test util-16.1.17.174 {8.4 compatible formatting of doubles} \ +test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \ {expr {1e174}} \ 1.0000000000000001e+174 -test util-16.1.17.175 {8.4 compatible formatting of doubles} \ +test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \ {expr {1e175}} \ 9.9999999999999994e+174 -test util-16.1.17.176 {8.4 compatible formatting of doubles} \ +test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \ {expr {1e176}} \ 1e+176 -test util-16.1.17.177 {8.4 compatible formatting of doubles} \ +test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \ {expr {1e177}} \ 1e+177 -test util-16.1.17.178 {8.4 compatible formatting of doubles} \ +test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \ {expr {1e178}} \ 1.0000000000000001e+178 -test util-16.1.17.179 {8.4 compatible formatting of doubles} \ +test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \ {expr {1e179}} \ 9.9999999999999998e+178 -test util-16.1.17.180 {8.4 compatible formatting of doubles} \ +test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \ {expr {1e180}} \ 1e+180 -test util-16.1.17.181 {8.4 compatible formatting of doubles} \ +test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \ {expr {1e181}} \ 9.9999999999999992e+180 -test util-16.1.17.182 {8.4 compatible formatting of doubles} \ +test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \ {expr {1e182}} \ 1.0000000000000001e+182 -test util-16.1.17.183 {8.4 compatible formatting of doubles} \ +test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \ {expr {1e183}} \ 9.9999999999999995e+182 -test util-16.1.17.184 {8.4 compatible formatting of doubles} \ +test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \ {expr {1e184}} \ 1e+184 -test util-16.1.17.185 {8.4 compatible formatting of doubles} \ +test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \ {expr {1e185}} \ 9.9999999999999998e+184 -test util-16.1.17.186 {8.4 compatible formatting of doubles} \ +test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \ {expr {1e186}} \ 9.9999999999999998e+185 -test util-16.1.17.187 {8.4 compatible formatting of doubles} \ +test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \ {expr {1e187}} \ 9.9999999999999991e+186 -test util-16.1.17.188 {8.4 compatible formatting of doubles} \ +test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \ {expr {1e188}} \ 1e+188 -test util-16.1.17.189 {8.4 compatible formatting of doubles} \ +test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \ {expr {1e189}} \ 1e+189 -test util-16.1.17.190 {8.4 compatible formatting of doubles} \ +test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \ {expr {1e190}} \ 1.0000000000000001e+190 -test util-16.1.17.191 {8.4 compatible formatting of doubles} \ +test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \ {expr {1e191}} \ 1.0000000000000001e+191 -test util-16.1.17.192 {8.4 compatible formatting of doubles} \ +test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \ {expr {1e192}} \ 1e+192 -test util-16.1.17.193 {8.4 compatible formatting of doubles} \ +test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \ {expr {1e193}} \ 1.0000000000000001e+193 -test util-16.1.17.194 {8.4 compatible formatting of doubles} \ +test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \ {expr {1e194}} \ 9.9999999999999994e+193 -test util-16.1.17.195 {8.4 compatible formatting of doubles} \ +test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \ {expr {1e195}} \ 9.9999999999999998e+194 -test util-16.1.17.196 {8.4 compatible formatting of doubles} \ +test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \ {expr {1e196}} \ 9.9999999999999995e+195 -test util-16.1.17.197 {8.4 compatible formatting of doubles} \ +test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \ {expr {1e197}} \ 9.9999999999999995e+196 -test util-16.1.17.198 {8.4 compatible formatting of doubles} \ +test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \ {expr {1e198}} \ 1e+198 -test util-16.1.17.199 {8.4 compatible formatting of doubles} \ +test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \ {expr {1e199}} \ 1.0000000000000001e+199 -test util-16.1.17.200 {8.4 compatible formatting of doubles} \ +test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \ {expr {1e200}} \ 9.9999999999999997e+199 -test util-16.1.17.201 {8.4 compatible formatting of doubles} \ +test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \ {expr {1e201}} \ 1e+201 -test util-16.1.17.202 {8.4 compatible formatting of doubles} \ +test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \ {expr {1e202}} \ 9.999999999999999e+201 -test util-16.1.17.203 {8.4 compatible formatting of doubles} \ +test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \ {expr {1e203}} \ 9.9999999999999999e+202 -test util-16.1.17.204 {8.4 compatible formatting of doubles} \ +test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \ {expr {1e204}} \ 9.9999999999999999e+203 -test util-16.1.17.205 {8.4 compatible formatting of doubles} \ +test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \ {expr {1e205}} \ 1e+205 -test util-16.1.17.206 {8.4 compatible formatting of doubles} \ +test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \ {expr {1e206}} \ 1e+206 -test util-16.1.17.207 {8.4 compatible formatting of doubles} \ +test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \ {expr {1e207}} \ 1e+207 -test util-16.1.17.208 {8.4 compatible formatting of doubles} \ +test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \ {expr {1e208}} \ 9.9999999999999998e+207 -test util-16.1.17.209 {8.4 compatible formatting of doubles} \ +test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \ {expr {1e209}} \ 1.0000000000000001e+209 -test util-16.1.17.210 {8.4 compatible formatting of doubles} \ +test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \ {expr {1e210}} \ 9.9999999999999993e+209 -test util-16.1.17.211 {8.4 compatible formatting of doubles} \ +test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \ {expr {1e211}} \ 9.9999999999999996e+210 -test util-16.1.17.212 {8.4 compatible formatting of doubles} \ +test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \ {expr {1e212}} \ 9.9999999999999991e+211 -test util-16.1.17.213 {8.4 compatible formatting of doubles} \ +test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \ {expr {1e213}} \ 9.9999999999999998e+212 -test util-16.1.17.214 {8.4 compatible formatting of doubles} \ +test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \ {expr {1e214}} \ 9.9999999999999995e+213 -test util-16.1.17.215 {8.4 compatible formatting of doubles} \ +test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \ {expr {1e215}} \ 9.9999999999999991e+214 -test util-16.1.17.216 {8.4 compatible formatting of doubles} \ +test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \ {expr {1e216}} \ 1e+216 -test util-16.1.17.217 {8.4 compatible formatting of doubles} \ +test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \ {expr {1e217}} \ 9.9999999999999996e+216 -test util-16.1.17.218 {8.4 compatible formatting of doubles} \ +test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \ {expr {1e218}} \ 1.0000000000000001e+218 -test util-16.1.17.219 {8.4 compatible formatting of doubles} \ +test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \ {expr {1e219}} \ 9.9999999999999997e+218 -test util-16.1.17.220 {8.4 compatible formatting of doubles} \ +test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \ {expr {1e220}} \ 1e+220 -test util-16.1.17.221 {8.4 compatible formatting of doubles} \ +test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \ {expr {1e221}} \ 1e+221 -test util-16.1.17.222 {8.4 compatible formatting of doubles} \ +test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \ {expr {1e222}} \ 1e+222 -test util-16.1.17.223 {8.4 compatible formatting of doubles} \ +test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \ {expr {1e223}} \ 1e+223 -test util-16.1.17.224 {8.4 compatible formatting of doubles} \ +test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \ {expr {1e224}} \ 9.9999999999999997e+223 -test util-16.1.17.225 {8.4 compatible formatting of doubles} \ +test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \ {expr {1e225}} \ 9.9999999999999993e+224 -test util-16.1.17.226 {8.4 compatible formatting of doubles} \ +test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \ {expr {1e226}} \ 9.9999999999999996e+225 -test util-16.1.17.227 {8.4 compatible formatting of doubles} \ +test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \ {expr {1e227}} \ 1.0000000000000001e+227 -test util-16.1.17.228 {8.4 compatible formatting of doubles} \ +test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \ {expr {1e228}} \ 9.9999999999999992e+227 -test util-16.1.17.229 {8.4 compatible formatting of doubles} \ +test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \ {expr {1e229}} \ 9.9999999999999999e+228 -test util-16.1.17.230 {8.4 compatible formatting of doubles} \ +test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \ {expr {1e230}} \ 1.0000000000000001e+230 -test util-16.1.17.231 {8.4 compatible formatting of doubles} \ +test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \ {expr {1e231}} \ 1.0000000000000001e+231 -test util-16.1.17.232 {8.4 compatible formatting of doubles} \ +test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \ {expr {1e232}} \ 1.0000000000000001e+232 -test util-16.1.17.233 {8.4 compatible formatting of doubles} \ +test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \ {expr {1e233}} \ 9.9999999999999997e+232 -test util-16.1.17.234 {8.4 compatible formatting of doubles} \ +test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \ {expr {1e234}} \ 1e+234 -test util-16.1.17.235 {8.4 compatible formatting of doubles} \ +test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \ {expr {1e235}} \ 1.0000000000000001e+235 -test util-16.1.17.236 {8.4 compatible formatting of doubles} \ +test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \ {expr {1e236}} \ 1.0000000000000001e+236 -test util-16.1.17.237 {8.4 compatible formatting of doubles} \ +test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \ {expr {1e237}} \ 9.9999999999999994e+236 -test util-16.1.17.238 {8.4 compatible formatting of doubles} \ +test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \ {expr {1e238}} \ 1e+238 -test util-16.1.17.239 {8.4 compatible formatting of doubles} \ +test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \ {expr {1e239}} \ 9.9999999999999999e+238 -test util-16.1.17.240 {8.4 compatible formatting of doubles} \ +test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \ {expr {1e240}} \ 1e+240 -test util-16.1.17.241 {8.4 compatible formatting of doubles} \ +test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \ {expr {1e241}} \ 1.0000000000000001e+241 -test util-16.1.17.242 {8.4 compatible formatting of doubles} \ +test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \ {expr {1e242}} \ 1.0000000000000001e+242 -test util-16.1.17.243 {8.4 compatible formatting of doubles} \ +test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \ {expr {1e243}} \ 1.0000000000000001e+243 -test util-16.1.17.244 {8.4 compatible formatting of doubles} \ +test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \ {expr {1e244}} \ 1.0000000000000001e+244 -test util-16.1.17.245 {8.4 compatible formatting of doubles} \ +test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \ {expr {1e245}} \ 1e+245 -test util-16.1.17.246 {8.4 compatible formatting of doubles} \ +test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \ {expr {1e246}} \ 1.0000000000000001e+246 -test util-16.1.17.247 {8.4 compatible formatting of doubles} \ +test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \ {expr {1e247}} \ 9.9999999999999995e+246 -test util-16.1.17.248 {8.4 compatible formatting of doubles} \ +test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \ {expr {1e248}} \ 1e+248 -test util-16.1.17.249 {8.4 compatible formatting of doubles} \ +test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \ {expr {1e249}} \ 9.9999999999999992e+248 -test util-16.1.17.250 {8.4 compatible formatting of doubles} \ +test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \ {expr {1e250}} \ 9.9999999999999992e+249 -test util-16.1.17.251 {8.4 compatible formatting of doubles} \ +test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \ {expr {1e251}} \ 1e+251 -test util-16.1.17.252 {8.4 compatible formatting of doubles} \ +test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \ {expr {1e252}} \ 1.0000000000000001e+252 -test util-16.1.17.253 {8.4 compatible formatting of doubles} \ +test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \ {expr {1e253}} \ 9.9999999999999994e+252 -test util-16.1.17.254 {8.4 compatible formatting of doubles} \ +test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \ {expr {1e254}} \ 9.9999999999999994e+253 -test util-16.1.17.255 {8.4 compatible formatting of doubles} \ +test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \ {expr {1e255}} \ 9.9999999999999999e+254 -test util-16.1.17.256 {8.4 compatible formatting of doubles} \ +test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \ {expr {1e256}} \ 1e+256 -test util-16.1.17.257 {8.4 compatible formatting of doubles} \ +test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \ {expr {1e257}} \ 1e+257 -test util-16.1.17.258 {8.4 compatible formatting of doubles} \ +test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \ {expr {1e258}} \ 1.0000000000000001e+258 -test util-16.1.17.259 {8.4 compatible formatting of doubles} \ +test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \ {expr {1e259}} \ 9.9999999999999993e+258 -test util-16.1.17.260 {8.4 compatible formatting of doubles} \ +test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \ {expr {1e260}} \ 1.0000000000000001e+260 -test util-16.1.17.261 {8.4 compatible formatting of doubles} \ +test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \ {expr {1e261}} \ 9.9999999999999993e+260 -test util-16.1.17.262 {8.4 compatible formatting of doubles} \ +test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \ {expr {1e262}} \ 1e+262 -test util-16.1.17.263 {8.4 compatible formatting of doubles} \ +test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \ {expr {1e263}} \ 1e+263 -test util-16.1.17.264 {8.4 compatible formatting of doubles} \ +test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \ {expr {1e264}} \ 1e+264 -test util-16.1.17.265 {8.4 compatible formatting of doubles} \ +test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \ {expr {1e265}} \ 1.0000000000000001e+265 -test util-16.1.17.266 {8.4 compatible formatting of doubles} \ +test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \ {expr {1e266}} \ 1e+266 -test util-16.1.17.267 {8.4 compatible formatting of doubles} \ +test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \ {expr {1e267}} \ 9.9999999999999997e+266 -test util-16.1.17.268 {8.4 compatible formatting of doubles} \ +test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \ {expr {1e268}} \ 9.9999999999999997e+267 -test util-16.1.17.269 {8.4 compatible formatting of doubles} \ +test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \ {expr {1e269}} \ 1e+269 -test util-16.1.17.270 {8.4 compatible formatting of doubles} \ +test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \ {expr {1e270}} \ 1e+270 -test util-16.1.17.271 {8.4 compatible formatting of doubles} \ +test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \ {expr {1e271}} \ 9.9999999999999995e+270 -test util-16.1.17.272 {8.4 compatible formatting of doubles} \ +test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \ {expr {1e272}} \ 1.0000000000000001e+272 -test util-16.1.17.273 {8.4 compatible formatting of doubles} \ +test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \ {expr {1e273}} \ 9.9999999999999995e+272 -test util-16.1.17.274 {8.4 compatible formatting of doubles} \ +test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \ {expr {1e274}} \ 9.9999999999999992e+273 -test util-16.1.17.275 {8.4 compatible formatting of doubles} \ +test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \ {expr {1e275}} \ 9.9999999999999996e+274 -test util-16.1.17.276 {8.4 compatible formatting of doubles} \ +test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \ {expr {1e276}} \ 1.0000000000000001e+276 -test util-16.1.17.277 {8.4 compatible formatting of doubles} \ +test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \ {expr {1e277}} \ 1e+277 -test util-16.1.17.278 {8.4 compatible formatting of doubles} \ +test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \ {expr {1e278}} \ 9.9999999999999996e+277 -test util-16.1.17.279 {8.4 compatible formatting of doubles} \ +test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \ {expr {1e279}} \ 1.0000000000000001e+279 -test util-16.1.17.280 {8.4 compatible formatting of doubles} \ +test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \ {expr {1e280}} \ 1e+280 -test util-16.1.17.281 {8.4 compatible formatting of doubles} \ +test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \ {expr {1e281}} \ 1e+281 -test util-16.1.17.282 {8.4 compatible formatting of doubles} \ +test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \ {expr {1e282}} \ 1e+282 -test util-16.1.17.283 {8.4 compatible formatting of doubles} \ +test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \ {expr {1e283}} \ 9.9999999999999996e+282 -test util-16.1.17.284 {8.4 compatible formatting of doubles} \ +test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \ {expr {1e284}} \ 1.0000000000000001e+284 -test util-16.1.17.285 {8.4 compatible formatting of doubles} \ +test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \ {expr {1e285}} \ 9.9999999999999998e+284 -test util-16.1.17.286 {8.4 compatible formatting of doubles} \ +test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \ {expr {1e286}} \ 1e+286 -test util-16.1.17.287 {8.4 compatible formatting of doubles} \ +test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \ {expr {1e287}} \ 1.0000000000000001e+287 -test util-16.1.17.288 {8.4 compatible formatting of doubles} \ +test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \ {expr {1e288}} \ 1e+288 -test util-16.1.17.289 {8.4 compatible formatting of doubles} \ +test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \ {expr {1e289}} \ 1.0000000000000001e+289 -test util-16.1.17.290 {8.4 compatible formatting of doubles} \ +test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \ {expr {1e290}} \ 1.0000000000000001e+290 -test util-16.1.17.291 {8.4 compatible formatting of doubles} \ +test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \ {expr {1e291}} \ 9.9999999999999996e+290 -test util-16.1.17.292 {8.4 compatible formatting of doubles} \ +test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \ {expr {1e292}} \ 1e+292 -test util-16.1.17.293 {8.4 compatible formatting of doubles} \ +test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \ {expr {1e293}} \ 9.9999999999999992e+292 -test util-16.1.17.294 {8.4 compatible formatting of doubles} \ +test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \ {expr {1e294}} \ 1.0000000000000001e+294 -test util-16.1.17.295 {8.4 compatible formatting of doubles} \ +test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \ {expr {1e295}} \ 9.9999999999999998e+294 -test util-16.1.17.296 {8.4 compatible formatting of doubles} \ +test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \ {expr {1e296}} \ 9.9999999999999998e+295 -test util-16.1.17.297 {8.4 compatible formatting of doubles} \ +test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \ {expr {1e297}} \ 1e+297 -test util-16.1.17.298 {8.4 compatible formatting of doubles} \ +test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \ {expr {1e298}} \ 9.9999999999999996e+297 -test util-16.1.17.299 {8.4 compatible formatting of doubles} \ +test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \ {expr {1e299}} \ 1.0000000000000001e+299 -test util-16.1.17.300 {8.4 compatible formatting of doubles} \ +test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \ {expr {1e300}} \ 1.0000000000000001e+300 -test util-16.1.17.301 {8.4 compatible formatting of doubles} \ +test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \ {expr {1e301}} \ 1.0000000000000001e+301 -test util-16.1.17.302 {8.4 compatible formatting of doubles} \ +test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \ {expr {1e302}} \ 1.0000000000000001e+302 -test util-16.1.17.303 {8.4 compatible formatting of doubles} \ +test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \ {expr {1e303}} \ 1e+303 -test util-16.1.17.304 {8.4 compatible formatting of doubles} \ +test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \ {expr {1e304}} \ 9.9999999999999994e+303 -test util-16.1.17.305 {8.4 compatible formatting of doubles} \ +test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \ {expr {1e305}} \ 9.9999999999999994e+304 -test util-16.1.17.306 {8.4 compatible formatting of doubles} \ +test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \ {expr {1e306}} \ 1e+306 -test util-16.1.17.307 {8.4 compatible formatting of doubles} \ +test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \ {expr {1e307}} \ 9.9999999999999999e+306 @@ -4063,7 +4130,57 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { 0x4400000000000000 0xc400000000000000 }] -set ::tcl_precision $saved_precision +test util-18.1 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr {2**63-1}] +} {9223372036854775807} + +test util-18.2 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr {2**63-1}] +} {9223372036854775807} + +test util-18.3 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr {2**63-1}] +} {9223372036854775807} + +test util-18.4 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr {2**63-1}] +} {9223372036854775807} + +test util-18.5 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr {-2**63}] +} {-9223372036854775808} + +test util-18.6 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr {-2**63}] +} {-9223372036854775808} + +test util-18.7 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr {-2**63}] +} {-9223372036854775808} + +test util-18.8 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr {-2**63}] +} {-9223372036854775808} + +test util-18.9 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %I32d" [expr {-2**63+2}] +} {-9223372036854775806 2} + +test util-18.10 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %p" 65535 +} {65535 0xffff} + +test util-18.11 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %td" 65536 +} {65536 65536} + +test util-18.12 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %Id" 65537 +} {65537 65537} + +if {[catch {set ::tcl_precision $saved_precision}]} { + unset ::tcl_precision +} # cleanup ::tcltest::cleanupTests diff --git a/tests/var.test b/tests/var.test index 968337b..5300adc 100644 --- a/tests/var.test +++ b/tests/var.test @@ -8,8 +8,8 @@ # 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. @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] @@ -41,6 +41,7 @@ if {[testConstraint memory]} { } } + catch {rename p ""} catch {namespace delete test_ns_var} catch {unset xx} @@ -202,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} @@ -596,10 +597,10 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var variable info set info [concat $info [list $name1 $name2 $op]] } - trace var v u [namespace code traceUnset] + trace add var v unset [namespace code traceUnset] } list [unset test_ns_var::v] $test_ns_var::info -} -result {{} {test_ns_var::v {} u}} +} -result {{} {test_ns_var::v {} unset}} test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} @@ -607,13 +608,13 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit set info "" namespace eval test_ns_var { variable v 123 1 - trace var v u ::traceUnset + trace add var v unset ::traceUnset } proc traceUnset {name1 name2 op} { set ::info [concat $::info [list $name1 $name2 $op]] } list [namespace delete test_ns_var] $::info -} -result {{} {::test_ns_var::v {} u}} +} -result {{} {::test_ns_var::v {} unset}} test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { proc ::t {a i o} { @@ -623,7 +624,7 @@ test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { leaktest { namespace eval n { variable v 123 - trace variable v u ::t + trace add variable v unset ::t } namespace delete n } @@ -702,8 +703,8 @@ test var-9.9 {behaviour of TclGetVar read trace success} -setup { } -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} set u 10 - trace var u r [list resetvar 1] - trace var v r [list resetvar 2] + trace add var u read [list resetvar 1] + trace add var v read [list resetvar 2] list \ [testsetnoerr u] \ [testseterr v] @@ -711,7 +712,7 @@ test var-9.9 {behaviour of TclGetVar read trace success} -setup { test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 - trace var v r writeonly + trace add var v read writeonly list \ [catch {testsetnoerr v} msg] $msg \ [catch {testseterr v} msg] $msg @@ -722,8 +723,8 @@ test var-9.11 {behaviour of TclSetVar write trace success} -setup { } -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} set v 1 - trace var v w doubleval - trace var u w doubleval + trace add var v write doubleval + trace add var u write doubleval list \ [testsetnoerr u 2] \ [testseterr v 3] @@ -731,7 +732,7 @@ test var-9.11 {behaviour of TclSetVar write trace success} -setup { test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 - trace var v w readonly + trace add var v write readonly list \ [catch {testsetnoerr v 2} msg] $msg $v \ [catch {testseterr v 3} msg] $msg $v @@ -793,7 +794,7 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { } namespace eval :: { set t(1) 1 - trace variable t(1) u foo + trace add variable t(1) unset foo unset t } set x "If you see this, it worked" @@ -1016,9 +1017,6 @@ test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { } -result 1 test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } proc doit k { variable A set A($k) {} @@ -1038,13 +1036,9 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A - rename getbytes {} rename doit {} } -result 0 test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } proc doit {} { interp create child child eval { @@ -1066,15 +1060,431 @@ test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup { set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A - rename getbytes {} rename doit {} } -result 0 +test var-22.2 {leak in parsedVarName} -constraints memory -body { + set i 0 + leaktest {lappend x($i)} +} -cleanup { + unset -nocomplain i x +} -result 0 +unset -nocomplain a k v +test var-23.1 {array command, for loop, too many args} -returnCodes error -body { + array for {k v} c d e {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.2 {array command, for loop, not enough args} -returnCodes error -body { + array for {k v} {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.3 {array command, for loop, too many list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v w} a {} +} -result {must have two variable names} +test var-23.4 {array command, for loop, not enough list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k} a {} +} -result {must have two variable names} +test var-23.5 {array command, for loop, no array} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v} a {} +} -result {"a" isn't an array} +test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { + catch {rename p ""} +} -returnCodes error -body { + apply {{x} { + if {$x==1} { + return [array for {k v} a {}] + } + set a(x) 123 + }} 1 +} -result {"a" isn't an array} +test var-23.7 {array enumeration} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 3} +test var-23.9 {array enumeration, nested} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k1 v1} a { + lappend reslist $k1 $v1 + set r2 {} + array for {k2 v2} a { + lappend r2 $k2 $v2 + } + lappend reslist [lsort -stride 2 -index 0 $r2] + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 3 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} +test var-23.10 {array enumeration, delete key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + unset a(c) + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } + set retval +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist + unset -nocomplain retval +} -result {array changed during iteration*} +test var-23.11 {array enumeration, insert key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(e) 5 + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {array changed during iteration*} +test var-23.12 {array enumeration, change value} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(c) 9 + } + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 9} +test var-23.13 {array enumeration, number of traces} -setup { + set ::countarrayfor 0 + proc ::tracearrayfor { args } { + incr ::countarrayfor + } + unset -nocomplain ::a + set reslist [list] +} -body { + array set ::a {a 1 b 2 c 3} + foreach {k} [array names a] { + trace add variable ::a($k) read ::tracearrayfor + } + array for {k v} ::a { + lappend reslist $k $v + } + set ::countarrayfor +} -cleanup { + unset -nocomplain ::countarrayfor + unset -nocomplain ::a + unset -nocomplain reslist +} -result 3 +test var-23.14 {array for, shared arguments} -setup { + set vn {k v} + unset -nocomplain $vn +} -body { + array set $vn {a 1 b 2 c 3} + array for $vn $vn {} +} -cleanup { + unset -nocomplain $vn vn +} -result {} + +test var-24.1 {array default set and get: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] +} -cleanup { + unset -nocomplain ary +} -result {3 7 1 0 7} +test var-24.2 {array default set and get: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] + }} +} {3 7 1 0 7} +test var-24.3 {array default unset: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] +} -cleanup { + unset -nocomplain ary +} -result {3 7 {} 3 1} +test var-24.4 {array default unset: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) \ + [catch {set ary(b)}] + }} +} {3 7 {} 3 1} +test var-24.5 {array default exists: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] +} -cleanup { + unset -nocomplain ary result +} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.6 {array default exists: compiled} { + apply {{} { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] + }} +} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.7 {array default and append: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.8 {array default and append: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.9 {array default and lappend: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.10 {array default and lappend: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.11 {array default and incr: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 18 2 19 1} +test var-24.12 {array default and incr: compiled} { + apply {{} { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 18 2 19 1} +test var-24.13 {array default and dict: interpreted} -setup { + unset -nocomplain ary x y z +} -body { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + lsort -stride 2 -index 0 [array get ary] +} -cleanup { + unset -nocomplain ary x y z +} -result {p {x {y z}} q {x z} r {x 123}} +test var-24.14 {array default and dict: compiled} { + lsort -stride 2 -index 0 [apply {{} { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + array get ary + }}] +} {p {x {y z}} q {x z} r {x 123}} +test var-24.15 {array default set and get: two-level} { + apply {{} { + array set ary {a 3} + array default set ary 7 + apply {{} { + upvar 1 ary ary ary(c) c + lappend result $ary(a) $ary(b) $c + lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] + lappend result [array default get ary] + }} + }} +} {3 7 7 1 0 0 7} +test var-24.16 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default set ary 7 +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {can't array default set "ary": variable isn't array} +test var-24.17 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.18 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.19 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default get ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.20 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + array default get ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.21 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default exists ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.22 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + array default exists ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.23 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default unset ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.24 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + array default unset ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob catch {namespace delete ns} catch {unset arr} catch {unset v} +catch {rename getbytes ""} catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} diff --git a/tests/while-old.test b/tests/while-old.test index f5315fb..b5b69dc 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -6,9 +6,9 @@ # 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. @@ -92,7 +92,7 @@ test while-old-4.3 {errors in while loops} { test while-old-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test while-old-4.5 {errors in while loops} { catch {unset x} set x 1 diff --git a/tests/while.test b/tests/while.test index b804aa5..2bfab2a 100644 --- a/tests/while.test +++ b/tests/while.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) 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. @@ -32,7 +32,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} -body { } -match glob -result {*"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} -body { while {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { set value 1 while {($tcl_platform(platform) != "foobar1") && \ @@ -343,7 +343,7 @@ test while-4.3 {while (not compiled): error in test expression} -body { test while-4.4 {while (not compiled): error in test expression} -body { set z while $z {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-4.5 {while (not compiled): multiline test expr} -body { set value 1 set z while diff --git a/tests/winConsole.test b/tests/winConsole.test index 9075ff3..3f23c07 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -4,7 +4,7 @@ # 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. @@ -14,34 +14,361 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +catch {package require twapi} ;# Only to bring window to foreground. Not critical -test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { - set oldmode [fconfigure stdin] +::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} } + +# Prompt user for a yes/no response +proc yesno {question {default "Y"}} { + set answer "" + # Make sure we are seen but catch because ui and console + # packages may not be available + catch {twapi::set_foreground_window [twapi::get_console_window]} + while {![string is boolean -strict $answer]} { + puts -nonewline stdout "$question Type Y/N followed by Enter \[$default\] : " + flush stdout + set answer [string trim [gets stdin]] + if {$answer eq ""} { + set answer $default + } + } + return [expr {!! $answer}] +} - puts stdout "Enter abcdef<return> now: " nonewline +proc prompt {prompt} { + # Make sure we are seen but catch because twapi ui and console + # packages may not be available + catch {twapi::set_foreground_window [twapi::get_console_window]} + puts -nonewline stdout "$prompt" flush stdout +} + +# Input tests + +test console-input-1.0 {Console blocking gets} -constraints {win interactive} -body { + prompt "Type \"xyz\" and hit Enter: " + gets stdin +} -result xyz + +test console-input-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + set oldmode [fconfigure stdin] + + prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { - set result $line - } else { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { set result "gets failed" } } fconfigure stdin -blocking 0 -buffering line - set result {} vwait result #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode + set result + +} -result {abc def} + +test console-input-1.1.1 {Bug baa51423c28a: Console file channel: fileevent with blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + prompt "Type \"abc\" and hit Enter: " + fileevent stdin readable { + if {[gets stdin line] >= 0} { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { + set result "gets failed" + } + } + + vwait result + #cleanup the fileevent + fileevent stdin readable {} + set result + +} -result {abc def} + +test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { + set oldmode [fconfigure stdin] + fconfigure stdin -inputmode raw +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." + set c [read stdin 1] + puts "" + set c +} -result a + +test console-input-2.1 {Console file channel: non-blocking read} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdin] +} -cleanup { + fconfigure stdin {*}$oldmode + puts ""; # Because CRLF also would not have been echoed +} -body { + set input "" + fconfigure stdin -blocking 0 -buffering line -inputmode raw + prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed." + + fileevent stdin readable { + set c [read stdin 1] + if {$c eq ""} { + if {[eof stdin]} { + set result "read eof" + } + } else { + append input $c + if {[string length $input] == 3} { + set result $input + } + } + } + + set result {} + vwait result + fileevent stdin readable {} set result +} -result abc + +# Output tests + +test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts stdout "123" + yesno "Did you see the string \"123\"?" +} -result 1 + +test console-output-1.1 {Console non-blocking puts stdout} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdout] + dict unset oldmode -winsize +} -cleanup { + fconfigure stdout {*}$oldmode +} -body { + fconfigure stdout -blocking 0 -buffering line + set count 0 + fileevent stdout writable { + if {[incr count] < 4} { + puts "$count" + } else { + fileevent stdout writable {} + set done 1 + } + } + vwait done + yesno "Did you see 1, 2, 3 printed on consecutive lines?" +} -result 1 + +test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { + puts stderr "456" + yesno "Did you see the string \"456\"?" +} -result 1 + + +# fconfigure get tests + +## fconfigure get stdin + +test console-fconfigure-get-1.0 { + Console get stdin configuration +} -constraints {win interactive} -body { + lsort [dict keys [fconfigure stdin]] +} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -profile -translation} + +set testnum 0 +foreach {opt result} { + -blocking 1 + -buffering line + -buffersize 4096 + -encoding utf-16 + -inputmode normal + -translation auto +} { + test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \ + -constraints {win interactive} -body { + fconfigure stdin $opt + } -result $result +} +test console-fconfigure-get-1.[incr testnum] { + Console get stdin option -eofchar +} -constraints {win interactive} -body { + fconfigure stdin -eofchar +} -result \x1A + +test console-fconfigure-get-1.[incr testnum] { + fconfigure -winsize +} -constraints {win interactive} -body { + fconfigure stdin -winsize +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -inputmode} -returnCodes error + +## fconfigure get stdout/stderr +foreach chan {stdout stderr} major {2 3} { + test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints { + win interactive + } -body { + lsort [dict keys [fconfigure $chan]] + } -result {-blocking -buffering -buffersize -encoding -eofchar -profile -translation -winsize} + set testnum 0 + foreach {opt result} { + -blocking 1 + -buffersize 4096 + -encoding utf-16 + -translation crlf + } { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \ + -constraints {win interactive} -body { + fconfigure $chan $opt + } -result $result + } + + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \ + -constraints {win interactive} -body { + fconfigure $chan -winsize + } -result {\d+ \d+} -match regexp + + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \ + -constraints {win interactive} -body { + fconfigure $chan -buffering + } -result [expr {$chan eq "stdout" ? "line" : "none"}] + + test console-fconfigure-get-$major.[incr testnum] { + fconfigure -inputmode + } -constraints {win interactive} -body { + fconfigure $chan -inputmode + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -winsize} -returnCodes error + +} + +## fconfigure set stdin + +test console-fconfigure-set-1.0 { + fconfigure -inputmode password +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"norm\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 norm normal 1] + +test console-fconfigure-set-1.1 { + fconfigure -inputmode raw +} -constraints {win interactive} -body { + set result {} + + prompt "Type the keys \"a\", Ctrl-H, \"b\". Do NOT hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode raw + lappend result [read stdin 3] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed (c replaced by d)?"] + + set result +} -result [list a\x08b raw 0 d normal 1] + +test console-fconfigure-set-1.2 { + fconfigure -inputmode reset +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode reset + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"reset\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 reset normal 1] + +test console-fconfigure-set-1.3 { + fconfigure stdin -winsize +} -constraints {win interactive} -body { + fconfigure stdin -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -inputmode} -returnCodes error + +## fconfigure set stdout,stderr + +test console-fconfigure-set-2.0 { + fconfigure stdout -winsize +} -constraints {win interactive} -body { + fconfigure stdout -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, or -translation} -returnCodes error + +test console-fconfigure-set-3.0 { + fconfigure stderr -winsize +} -constraints {win interactive} -body { + fconfigure stderr -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -profile, -translation} -returnCodes error + +# Multiple threads -} "abcdef" +test console-thread-input-1.0 {Get input in thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + prompt "Type \"xyz\" and hit Enter: " + thread::send $tid {gets stdin} +} -result xyz -#cleanup +test console-thread-output-1.0 {Output from thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + thread::send $tid {puts [thread::id]} + yesno "Did you see $tid printed?" +} -result 1 ::tcltest::cleanupTests return diff --git a/tests/winDde.test b/tests/winDde.test index a526d0d..8f4da11 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -4,27 +4,27 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 - #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] -testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.4] - set ::ddelib [info loaded "" Dde]}]} { + set ::ddever [package require dde 1.4.5] + set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # ------------------------------------------------------------------------- @@ -37,6 +37,7 @@ proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] + fconfigure $f -encoding utf-8 puts $f [list set ddeServerName $ddeServerName] puts $f [list load $::ddelib Dde] puts $f { @@ -96,7 +97,7 @@ proc createChildProcess {ddeServerName args} { # run the child server script. set f [open |[list [interpreter] $::scriptName] r] - fconfigure $f -buffering line + fconfigure $f -buffering line -encoding utf-8 gets $f line return $f } @@ -104,7 +105,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.4} +} {1.4.5} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] @@ -129,104 +130,104 @@ test winDde-2.4 {Checking for existence, with only the topic specified} \ # ------------------------------------------------------------------------- test winDde-3.1 {DDE execute locally} -constraints dde -body { - set \xe1 "" - dde execute TclEval self [list set \xe1 foo] - set \xe1 + set \xE1 "" + dde execute TclEval self [list set \xE1 foo] + set \xE1 } -result foo test winDde-3.2 {DDE execute -async locally} -constraints dde -body { - set \xe1 "" - dde execute -async TclEval self [list set \xe1 foo] + set \xE1 "" + dde execute -async TclEval self [list set \xE1 foo] update - set \xe1 + set \xE1 } -result foo test winDde-3.3 {DDE request locally} -constraints dde -body { - set \xe1 "" - dde execute TclEval self [list set \xe1 foo] - dde request TclEval self \xe1 + set \xE1 "" + dde execute TclEval self [list set \xE1 foo] + dde request TclEval self \xE1 } -result foo test winDde-3.4 {DDE eval locally} -constraints dde -body { - set \xe1 "" - dde eval self set \xe1 foo + set \xE1 "" + dde eval self set \xE1 foo } -result foo test winDde-3.5 {DDE request locally} -constraints dde -body { - set \xe1 "" - dde execute TclEval self [list set \xe1 foo] - dde request -binary TclEval self \xe1 + set \xE1 "" + dde execute TclEval self [list set \xE1 foo] + dde request -binary TclEval self \xE1 } -result "foo\x00" # Set variable a to A with diaeresis (Unicode C4) by relying on the fact # that 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 + 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" ) manually -test winDde-3.7 {DDE request binary} -constraints dde -body { - set \xe1 "not set" - dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] - scan [set \xe1] %c +test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body { + set \xE1 "not set" + dde execute -binary TclEval self [list set \xC3\xA1 \xC3\x84\x00] + scan [set \xE1] %c } -result 196 test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { - set \xe1 "" - dde poke TclEval self \xe1 \xc4 - dde request TclEval self \xe1 -} -result \xc4 + set \xE1 "" + dde poke TclEval self \xE1 \xC4 + dde request TclEval self \xE1 +} -result \xC4 test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { - set \xe1 "" - dde poke -binary TclEval self \xe1 \xc3\x84\x00 - dde request TclEval self \xe1 -} -result \xc4 + set \xE1 "" + dde poke -binary TclEval self \xE1 \xC3\x84\x00 + dde request TclEval self \xE1 +} -result \xC4 # ------------------------------------------------------------------------- test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body { - set \xe1 "" + set \xE1 "" set name ch\xEDld-4.1 set child [createChildProcess $name] - dde execute TclEval $name [list set \xe1 foo] + dde execute TclEval $name [list set \xE1 foo] dde execute TclEval $name {set done 1} update - set \xe1 + set \xE1 } -result "" test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body { - set \xe1 "" + set \xE1 "" set name ch\xEDld-4.2 set child [createChildProcess $name] - dde execute -async TclEval $name [list set \xe1 foo] + dde execute -async TclEval $name [list set \xE1 foo] update dde execute TclEval $name {set done 1} update - set \xe1 + set \xE1 } -result "" test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { - set \xe1 "" + set \xE1 "" set name ch\xEDld-4.3 set child [createChildProcess $name] - dde execute TclEval $name [list set \xe1 foo] - set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name [list set \xE1 foo] + set \xE1 [dde request TclEval $name \xE1] dde execute TclEval $name {set done 1} update - set \xe1 + set \xE1 } -result foo test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { - set \xe1 "" + set \xE1 "" set name ch\xEDld-4.4 set child [createChildProcess $name] - set \xe1 [dde eval $name set \xe1 foo] + set \xE1 [dde eval $name set \xE1 foo] dde execute TclEval $name {set done 1} update - set \xe1 + set \xE1 } -result foo test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { - set \xe1 "" + set \xE1 "" set name ch\xEDld-4.5 set child [createChildProcess $name] - dde poke TclEval $name \xe1 foo - set \xe1 [dde request TclEval $name \xe1] + dde poke TclEval $name \xE1 foo + set \xE1 [dde request TclEval $name \xE1] dde execute TclEval $name {set done 1} update - set \xe1 + set \xE1 } -result foo # ------------------------------------------------------------------------- @@ -401,8 +402,8 @@ test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval child set \xe1 1 - child eval set \xe1 + 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 child diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 3d0a9e0..9b5e67e 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -4,8 +4,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) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 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. @@ -16,13 +16,10 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Initialise the test constraints -testConstraint winVista 0 -testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] @@ -32,6 +29,7 @@ testConstraint longFileNames 0 # Some things fail under all Continuous Integration systems for subtle reasons # such as CI often running with elevated privileges in a container. testConstraint notInCIenv [expr {![info exists ::env(CI)]}] +testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] proc createfile {file {string a}} { set f [open $file w] @@ -64,18 +62,6 @@ proc cleanup {args} { } } -if {[testConstraint winOnly]} { - if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { - if {$::tcl_platform(osVersion) >= 6.0} { - testConstraint winVista 1 - } else { - testConstraint win2000orXP 1 - } - } else { - testConstraint winOlderThan2000 1 - } -} - # find a CD-ROM so we can test read-only filesystems. proc findfile {dir} { @@ -144,25 +130,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 @@ -215,19 +201,9 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup { } -cleanup { catch {close $fd} } -returnCodes error -result EACCES -test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win win2000orXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { createfile tf1 testfile mv tf1 nul } -returnCodes error -result EEXIST @@ -248,21 +224,9 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup { } -constraints {win testfile} -body { testfile mv tf1 tf2 } -returnCodes error -result ENOENT -test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win win2000orXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup -} -constraints {win nt testfile} -body { - # under 95, this would actually succeed and move the current dir out from - # under the current process! +} -constraints {win testfile} -body { file delete /tf1 testfile mv [pwd] /tf1 } -returnCodes error -result EACCES @@ -279,7 +243,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 @@ -325,21 +289,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 @@ -368,7 +332,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 @@ -419,7 +383,7 @@ proc MakeFiles {dirname} { test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup -} -constraints {win winNonZeroInodes notInCIenv} -body { +} -constraints {win winNonZeroInodes knownMsvcBug notInCIenv} -body { file mkdir td1 lassign [MakeFiles td1] a b file rename -force $a $b @@ -469,16 +433,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 win2000orXP testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EACCES test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -634,7 +588,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir -} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES +} -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -667,7 +621,7 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup { test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod notInCIenv} -body { +} -constraints {win testfile testchmod notInCIenv} -body { # Parent's FILE_DELETE_CHILD setting permits deletion of subdir # even when subdir DELETE mask is clear. So we need an intermediate # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W. @@ -725,14 +679,14 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup { # winFCmd-6.9 removed - was exact dup of winFCmd-6.1 test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile notInCIenv} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup -} -constraints {winVista testfile testchmod notInCIenv} -body { +} -constraints {win testfile testchmod notInCIenv} -body { # Parent's FILE_DELETE_CHILD setting permits deletion of subdir # even when subdir DELETE mask is clear. So we need an intermediate # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W. @@ -827,7 +781,7 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -result {tf1} test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ -} -constraints {win nt cdrom testfile} -returnCodes error -match glob \ +} -constraints {win cdrom testfile} -returnCodes error -match glob \ -result {* EACCES} test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ {win emptyTest} { @@ -866,7 +820,7 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -result {tf1} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { file mkdir td1 testfile cpdir td1 / } -cleanup { @@ -968,7 +922,7 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { } -result {} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup -} -constraints {winVista testfile testchmod notInCIenv} -body { +} -constraints {win testfile testchmod notInCIenv} -body { # Parent's FILE_DELETE_CHILD setting permits deletion of subdir # even when subdir DELETE mask is clear. So we need an intermediate # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W. @@ -1085,15 +1039,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 win2000orXP} -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 {} @@ -1161,7 +1107,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 {} @@ -1169,7 +1115,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 {} @@ -1202,7 +1148,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 {} @@ -1374,13 +1320,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 -test winFCmd-19.1 {Windows extended path names} -constraints nt -body { +test winFCmd-19.1 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.2 {Windows extended path names} -constraints nt -body { +test winFCmd-19.2 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/../windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.3 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1391,7 +1337,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.4 {Windows extended path names} -constraints {win nt} -setup { +test winFCmd-19.4 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1402,7 +1348,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints {win nt} -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.5 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1413,7 +1359,7 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.6 {Windows extended path names} -constraints {win nt} -setup { +test winFCmd-19.6 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1424,7 +1370,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints {win nt} -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.7 {Windows extended path names} -constraints {win nt} -setup { +test winFCmd-19.7 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile [file normalize $tmpfile] } -body { @@ -1435,7 +1381,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints {win nt} -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list tcl[pid].tmp]] -test winFCmd-19.8 {Windows extended path names} -constraints {win nt} -setup { +test winFCmd-19.8 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1447,7 +1393,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints {win nt} -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] -test winFCmd-19.9 {Windows devices path names} -constraints {win nt} -body { +test winFCmd-19.9 {Windows devices path names} -constraints win -body { file normalize //./com1 } -result //./com1 diff --git a/tests/winFile.test b/tests/winFile.test index 3737d9f..0c13a0e 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -4,40 +4,36 @@ # 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.5}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.5 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } -namespace import -force ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 -testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { - testConstraint win2000 1 -} +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { +test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nonPortable} { catch {glob ~stanton@workgroup} } {0} @@ -155,7 +151,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win nt notNTFS win2000 + win notNTFS notWine } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -170,7 +166,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win nt notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -181,7 +177,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win nt notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -193,7 +189,7 @@ test winFile-4.2 { test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -206,7 +202,7 @@ test winFile-4.3 { test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winNotify.test b/tests/winNotify.test index 0433b4a..52502a2 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -4,8 +4,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) 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::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 ce786db..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 2.5 -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] @@ -79,11 +84,11 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} { +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} -test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} { +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" @@ -169,14 +174,14 @@ 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} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { +test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { proc readResults {f} { global x result if { [eof $f] } { @@ -195,7 +200,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" -test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -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 ed8b625..0d7298f 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -4,8 +4,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) 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. @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::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]] diff --git a/tests/zipfs.test b/tests/zipfs.test new file mode 100644 index 0000000..bf9c969 --- /dev/null +++ b/tests/zipfs.test @@ -0,0 +1,410 @@ +# The file tests the tclZlib.c file. +# +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. +# +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +testConstraint zipfs [expr { + [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]] +}] +testConstraint zipfslib 1 + +set ziproot [zipfs root] +set CWD [pwd] +set tmpdir [file join $CWD tmp] +file mkdir $tmpdir + +test zipfs-0.0 {zipfs basics} -constraints zipfs -body { + package require tcl::zipfs +} -result {2.0} +test zipfs-0.1 {zipfs basics} -constraints zipfs -body { + expr {${ziproot} in [file volumes]} +} -result 1 + +if {![string match ${ziproot}* $tcl_library]} { + ### + # "make test" does not map tcl_library from the dynamic library on Unix + # + # Hack the environment to pretend we did pull tcl_library from a zip + # archive + ### + set tclzip [file join $CWD libtcl[info patchlevel].zip] + testConstraint zipfslib [file isfile $tclzip] + if {[testConstraint zipfslib]} { + zipfs mount /lib/tcl $tclzip + set ::tcl_library ${ziproot}lib/tcl/tcl_library + } +} + +test zipfs-0.2 {zipfs basics} -constraints zipfslib -body { + string match ${ziproot}* $tcl_library +} -result 1 +test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + expr { [file join . http] in [glob -dir . http*] } +} -cleanup { + cd $pwd +} -result 1 +test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + expr { [file join $tcl_library http] in [glob -dir [pwd] http*] } +} -cleanup { + cd $pwd +} -result 1 +test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body { + expr { [file join $tcl_library http] in [glob -dir $tcl_library http*] } +} -result 1 +test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body { + expr { [file join $tcl_library http] in [glob [file join $tcl_library http*]] } +} -result 1 +test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body { + expr { "http" in [glob -tails -dir $tcl_library http*] } +} -result 1 +test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body { + expr { "http" in [glob -nocomplain -tails -types d -dir $tcl_library http*] } +} -result 1 +test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body { + glob -nocomplain -tails -types f -dir $tcl_library http* +} -result {} +test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file join [zipfs root] bar baz +} -result "[zipfs root]bar/baz" +test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root] +} -result "[zipfs root]" +test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root]//bar/baz//qux/../ +} -result "[zipfs root]bar/baz" + +test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mount a b c d e f +} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"} +test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs unmount a b c d e f +} -result {wrong # args: should be "zipfs unmount zipfile"} +test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkkey a b c d e f +} -result {wrong # args: should be "zipfs mkkey password"} +test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkimg a b c d e f +} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"} +test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkzip a b c d e f +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs exists a b c d e f +} -result {wrong # args: should be "zipfs exists filename"} +test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs info a b c d e f +} -result {wrong # args: should be "zipfs info filename"} +test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs list a b c d e f +} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"} + +file mkdir tmp +test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body { + zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx +} -result {empty archive} +### +# The next series of tests operate within a zipfile created a temporary +# directory. +### +set zipfile [file join $tmpdir abc.zip] +if {[file exists $zipfile]} { + file delete $zipfile +} +test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + zipfs mount ${ziproot}abc $zipfile + zipfs list -glob ${ziproot}abc/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]abc/cp850.enc" +testConstraint zipfsenc [zipfs exists /abc/cp850.enc] +test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body { + set r [zipfs info ${ziproot}abc/cp850.enc] + lrange $r 0 2 +} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body { + set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body { + zipfs exists /abc/cp850.enc +} -result 1 +test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body { + zipfs unmount /abc +} -returnCodes error -result {filesystem is busy} +test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body { + close $zipfd + zipfs unmount /abc + zipfs exists /abc/cp850.enc +} -result 0 +### +# Repeat the tests for a buffer mounted archive +### +test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + set fin [open $zipfile r] + fconfigure $fin -translation binary + set dat [read $fin] + close $fin + zipfs mount_data def $dat + zipfs list -glob ${ziproot}def/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]def/cp850.enc" +testConstraint zipfsencbuf [zipfs exists /def/cp850.enc] +test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body { + set r [zipfs info ${ziproot}def/cp850.enc] + lrange $r 0 2 +} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body { + set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body { + zipfs exists /def/cp850.enc +} -result 1 +test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body { + zipfs unmount /def +} -returnCodes error -result {filesystem is busy} +test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body { + close $zipfd + zipfs unmount /def + zipfs exists /def/cp850.enc +} -result 0 + +catch {file delete -force $tmpdir} + +test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand mkzip of zipfs} + +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 + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/zlib.test b/tests/zlib.test index 5312d2b..42d9e9c 100644 --- a/tests/zlib.test +++ b/tests/zlib.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) 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. @@ -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 { @@ -286,23 +286,23 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { test zlib-8.6 {transformation and fconfigure} -setup { set file [makeFile {} test.z] set fd [open $file wb] -} -constraints zlib -body { +} -constraints {zlib deprecated} -body { list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] -} -constraints zlib -body { +} -constraints {zlib deprecated} -body { list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" |