diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2017-11-07 16:31:17 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2017-11-07 16:31:17 (GMT) |
commit | a7ba08158bc0b1ac6e73f6ee9c1b0b12312496cd (patch) | |
tree | d67676e3e6e33fbe6fadbccddc06fba2dd91fe3f /tests | |
parent | 16976013d10c1b40796a8769ad3852ce837b536c (diff) | |
parent | d0665d7a121733fde114a357da8ca7369a14aa39 (diff) | |
download | tcl-a7ba08158bc0b1ac6e73f6ee9c1b0b12312496cd.zip tcl-a7ba08158bc0b1ac6e73f6ee9c1b0b12312496cd.tar.gz tcl-a7ba08158bc0b1ac6e73f6ee9c1b0b12312496cd.tar.bz2 |
merge 8.7
Diffstat (limited to 'tests')
-rw-r--r-- | tests/assemble.test | 2 | ||||
-rw-r--r-- | tests/cmdAH.test | 8 | ||||
-rw-r--r-- | tests/encoding.test | 36 | ||||
-rw-r--r-- | tests/execute.test | 6 | ||||
-rw-r--r-- | tests/oo.test | 30 | ||||
-rw-r--r-- | tests/platform.test | 4 | ||||
-rw-r--r-- | tests/resolver.test | 9 | ||||
-rw-r--r-- | tests/string.test | 42 | ||||
-rw-r--r-- | tests/stringObj.test | 5 | ||||
-rw-r--r-- | tests/utf.test | 4 |
10 files changed, 91 insertions, 55 deletions
diff --git a/tests/assemble.test b/tests/assemble.test index d17bfd9..6e5308d 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -852,7 +852,7 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result] $result $errorCode + list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] } } -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3c58c1b..e334dff 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -188,7 +188,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system @@ -210,7 +210,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertfrom jis0208 8C } -cleanup { encoding system $system @@ -224,11 +224,11 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding system } -cleanup { encoding system $system -} -result identity +} -result iso8859-1 test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file diff --git a/tests/encoding.test b/tests/encoding.test index be1f4d5..e447c20 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,6 +34,8 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] testConstraint exec [llength [info commands exec]] testConstraint testgetencpath [llength [info commands testgetencpath]] @@ -75,11 +77,11 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found - encoding system identity + encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg } -cleanup { - encoding system identity + encoding system iso8859-1 encoding dirs $path encoding system $system } -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" @@ -136,7 +138,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { encoding system jis0208 encoding convertto \u4e4e } -cleanup { - encoding system identity + encoding system iso8859-1 encoding system $old } -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { @@ -259,7 +261,7 @@ test encoding-11.5.1 {LoadEncodingFile: escape file} { test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] - encoding system identity + encoding system iso8859-1 } -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] @@ -308,26 +310,18 @@ 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" - test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" -test encoding-15.2 {UtfToUtfProc null character output} { - set x \u0000 - set y [encoding convertto utf-8 \u0000] - set y [encoding convertfrom identity $y] - binary scan $y H* z - list [string bytelength $x] [string bytelength $y] $z -} {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} { - set x [encoding convertfrom identity \x00] - set y [encoding convertfrom utf-8 $x] - binary scan [encoding convertto identity $y] H* z - list [string bytelength $x] [string bytelength $y] $z -} {1 2 c080} +test encoding-15.2 {UtfToUtfProc null character output} testbytestring { + binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + set z +} 00 +test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + binary scan [teststringbytes $y] H* z + set z +} c080 test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] diff --git a/tests/execute.test b/tests/execute.test index 5b8ce2d..6c277f8 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -724,7 +724,7 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { } set result {} lappend result [expr $e] - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} @@ -733,11 +733,11 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu } -body { set e { [llength {}]+1 } set result {} - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] namespace eval foo { proc llength {args} {return 1} } - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} diff --git a/tests/oo.test b/tests/oo.test index 54c4b75..b6af1ee 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1482,6 +1482,36 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done + +test oo-11.6 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + trace add command obj3 delete [list obj3 dying] + rename obj2 {} + + # No segmentation fault + return done +} done test oo-12.1 {OO: filters} { oo::class create Aclass diff --git a/tests/platform.test b/tests/platform.test index 5838a41..8a68351 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -16,7 +16,9 @@ namespace eval ::tcl::test::platform { namespace import ::tcltest::test namespace import ::tcltest::cleanupTests - variable ::tcl_platform + # This is not how [variable] works. See TIP 276. + #variable ::tcl_platform + namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/resolver.test b/tests/resolver.test index 9bb4c08..b0b395d 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -139,13 +139,10 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s variable r2 "" } } -constraints testinterpresolver -body { - set r0 [namespace eval ::ns2 {x}] - set r1 [namespace eval ::ns2 {z}] - namespace eval ::ns2 { + list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 { namespace import ::ns1::z - set r2 [z] - } - list $r0 $r1 $r2 + z + }] } -cleanup { testinterpresolver down namespace delete ::ns2 diff --git a/tests/string.test b/tests/string.test index 549944d..cebaf4c 100644 --- a/tests/string.test +++ b/tests/string.test @@ -28,6 +28,11 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + test string-1.1 {error conditions} { list [catch {string gorp a b} 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}} @@ -224,6 +229,13 @@ test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 +test string-4.16 {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + list [representationpoke $s] [representationpoke $m] \ + [string first $m $s] +} {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg @@ -1685,40 +1697,40 @@ test string-24.4 {string reverse command - unshared string} { string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead + set x abcde\ud0ad string reverse $x -} \udeadedcba +} \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc - set y de\udead + set y de\ud0ad string reverse $x$y -} \udeadedcba +} \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead + string reverse \ud0ad +} \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead + set x \ubeef\ud0ad string reverse $x -} \udead\ubeef +} \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string reverse $x$y -} \udead\ubeef +} \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead + string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +} \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x @@ -2042,9 +2054,7 @@ test string-29.15 {string cat, efficiency} -setup { } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} - - - + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringObj.test b/tests/stringObj.test index 49f268e..a78b5f8 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -480,7 +480,6 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars @@ -489,3 +488,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/utf.test b/tests/utf.test index 422ab08..45f9c0c 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -68,10 +68,10 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestrin } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] -} -result {1} +} -result {2} test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] -} -result {1} +} -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { string length [testbytestring "\xF0\x8F\xBF\xBF"] } {4} |