diff options
Diffstat (limited to 'tests/stringComp.test')
| -rw-r--r-- | tests/stringComp.test | 374 |
1 files changed, 201 insertions, 173 deletions
diff --git a/tests/stringComp.test b/tests/stringComp.test index cf22346..165ef20 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -14,18 +14,35 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stringComp.test,v 1.15 2007/12/13 15:26:07 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # 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 @@ -33,7 +50,7 @@ test stringComp-1.1 {error conditions} { test stringComp-1.2 {error conditions} { proc foo {} {string} list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string subcommand ?argument ...?"}} +} {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. @@ -44,180 +61,166 @@ test stringComp-1.3 {error condition - undefined method during compile} { foo abc 0 } a -test stringComp-2.1 {string compare, too few args} { - proc foo {} {string compare a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.2 {string compare, bad args} { - proc foo {} {string compare a b c} - list [catch {foo} msg] $msg -} {1 {bad option "a": must be -nocase or -length}} -test stringComp-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg -} {1 {expected integer but got "-nocase"}} -test stringComp-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.6 {string compare} { - proc foo {} {string compare abcde abdef} - foo -} -1 -test stringComp-2.7 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} - foo -} 1 -test stringComp-2.8 {string compare} { - proc foo {} {string compare abcde abcde} - foo -} 0 -test stringComp-2.9 {string compare with length} { - proc foo {} {string compare -length 2 abcde abxyz} - foo -} 0 -test stringComp-2.10 {string compare with special index} { - proc foo {} {string compare -length end-3 abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.11 {string compare, unicode} { - proc foo {} {string compare ab\u7266 ab\u7267} - foo -} -1 -test stringComp-2.12 {string compare, high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - proc foo {} {string compare "\x80" "@"} - foo - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. -} 1 -test stringComp-2.13 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abdef} - foo -} -1 -test stringComp-2.14 {string compare -nocase} { - proc foo {} {string c -nocase abcde ABCDE} - foo -} 0 -test stringComp-2.15 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abcde} - foo -} 0 -test stringComp-2.16 {string compare -nocase with length} { - proc foo {} {string compare -length 2 -nocase abcde Abxyz} - foo -} 0 -test stringComp-2.17 {string compare -nocase with length} { - proc foo {} {string compare -nocase -length 3 abcde Abxyz} - foo -} -1 -test stringComp-2.18 {string compare -nocase with length <= 0} { - proc foo {} {string compare -nocase -length -1 abcde AbCdEf} - foo -} -1 -test stringComp-2.19 {string compare -nocase with excessive length} { - proc foo {} {string compare -nocase -length 50 AbCdEf abcde} - foo -} 1 -test stringComp-2.20 {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 - proc foo {} {string compare -len 5 \334\334\334 \334\334\374} - foo -} -1 -test stringComp-2.21 {string compare -nocase with special index} { - proc foo {} {string compare -nocase -length end-3 Abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.22 {string compare, null strings} { - proc foo {} {string compare "" ""} - foo -} 0 -test stringComp-2.23 {string compare, null strings} { - proc foo {} {string compare "" foo} - foo -} -1 -test stringComp-2.24 {string compare, null strings} { - proc foo {} {string compare foo ""} - foo -} 1 -test stringComp-2.25 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" ""} - foo -} 0 -test stringComp-2.26 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" foo} - foo -} -1 -test stringComp-2.27 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase foo ""} - foo -} 1 -test stringComp-2.28 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 abc abde} - foo -} 0 -test stringComp-2.29 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 ab abde} - foo -} 0 -test stringComp-2.30 {string compare with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - proc foo {} {string compare \x00 \x01} - foo -} -1 -test stringComp-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo -} 1 -test stringComp-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo -} -1 -test stringComp-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo -} -1 +## Test string compare|equal over equal constraints +## Use result for string compare, and negate it for string equal +## The body will be tested both in and outside a proc +set i 0 +foreach {tname tbody tresult tcode} { + {too few args} { + string compare a + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {bad args} { + string compare a b c + } {bad option "a": must be -nocase or -length} {error} + {bad args} { + string compare -length -nocase str1 str2 + } {expected integer but got "-nocase"} {error} + {too many args} { + string compare -length 10 -nocase str1 str2 str3 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {compare with length unspecified} { + string compare -length 10 10 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {basic operation fail} { + string compare abcde abdef + } {-1} {} + {basic operation success} { + string compare abcde abcde + } {0} {} + {with length} { + string compare -length 2 abcde abxyz + } {0} {} + {with special index} { + string compare -length end-3 abcde abxyz + } {expected integer but got "end-3"} {error} + {unicode} { + string compare ab\u7266 ab\u7267 + } {-1} {} + {unicode} {string compare \334 \u00dc} 0 {} + {unicode} {string compare \334 \u00fc} -1 {} + {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} + {high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. + } {1} {} + {-nocase 1} {string compare -nocase abcde abdef} {-1} {} + {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} + {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} + {-nocase 4} {string compare -nocase abcde abcde} {0} {} + {-nocase unicode} { + string compare -nocase \334 \u00dc + } 0 {} + {-nocase unicode} { + string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 + } 0 {} + {-nocase with length} { + string compare -length 2 -nocase abcde Abxyz + } {0} {} + {-nocase with length} { + string compare -nocase -length 3 abcde Abxyz + } {-1} {} + {-nocase with length <= 0} { + string compare -nocase -length -1 abcde AbCdEf + } {-1} {} + {-nocase with excessive length} { + string compare -nocase -length 50 AbCdEf abcde + } {1} {} + {-len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + string compare -len 5 \334\334\334 \334\334\374 + } -1 {} + {-nocase with special index} { + string compare -nocase -length end-3 Abcde abxyz + } {expected integer but got "end-3"} error + {null strings} { + string compare "" "" + } 0 {} + {null strings} { + string compare "" foo + } -1 {} + {null strings} { + string compare foo "" + } 1 {} + {-nocase null strings} { + string compare -nocase "" "" + } 0 {} + {-nocase null strings} { + string compare -nocase "" foo + } -1 {} + {-nocase null strings} { + string compare -nocase foo "" + } 1 {} + {with length, unequal strings} { + string compare -length 2 abc abde + } 0 {} + {with length, unequal strings} { + string compare -length 2 ab abde + } 0 {} + {with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + string compare \x00 \x01 + } -1 {} + {high bit} { + string compare "a\x80" "a@" + } 1 {} + {high bit} { + string compare "a\x00" "a\x01" + } -1 {} + {high bit} { + string compare "\x00\x00" "\x00\x01" + } -1 {} + {binary equal} { + string compare [binary format a100 0] [binary format a100 0] + } 0 {} + {binary neq} { + string compare [binary format a100a 0 1] [binary format a100a 0 0] + } 1 {} + {binary neq inequal length} { + string compare [binary format a20a 0 1] [binary format a100a 0 0] + } 1 {} +} { + if {$tname eq ""} { continue } + if {$tcode eq ""} { set tcode ok } + test stringComp-2.[incr i] "string compare, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string compare bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult + if {"error" ni $tcode} { + set tresult [expr {!$tresult}] + } else { + set tresult [string map {compare equal} $tresult] + } + set tbody [string map {compare equal} $tbody] + test stringComp-2.[incr i] "string equal, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string equal bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult +} -# only need a few tests on equal, since it uses the same code as -# string compare, but just modifies the return output -test stringComp-3.1 {string equal} { - proc foo {} {string equal abcde abdef} - foo -} 0 -test stringComp-3.2 {string equal} { - proc foo {} {string eq abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal} { - proc foo {} {string equal abcde abcde} - foo -} 1 -test stringComp-3.4 {string equal -nocase} { - proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} +# need a few extra tests short abbr cmd +test stringComp-3.1 {string compare, shortest method name} { + proc foo {} {string c abcde ABCDE} foo } 1 -test stringComp-3.5 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abdef} +test stringComp-3.2 {string equal, shortest method name} { + proc foo {} {string e abcde ABCDE} foo } 0 -test stringComp-3.6 {string equal -nocase} { +test stringComp-3.3 {string equal -nocase} { proc foo {} {string eq -nocase abcde ABCDE} foo } 1 -test stringComp-3.7 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abcde} - foo -} 1 -test stringComp-3.8 {string equal with length, unequal strings} { - proc foo {} {string equal -length 2 abc abde} - foo -} 1 test stringComp-4.1 {string first, too few args} { proc foo {} {string first a} @@ -690,13 +693,33 @@ test stringComp-11.54 {string match, failure} { } {0 1 1 1 0 0} ## string range -## not yet bc +test stringComp-12.1 {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} ## string repeat ## not yet bc ## string replace -## not yet bc +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} ## string tolower ## not yet bc @@ -712,7 +735,12 @@ test stringComp-11.54 {string match, failure} { ## string word* ## not yet bc - + # cleanup +catch {rename foo {}} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: |