summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorhobbs <hobbs>2003-02-18 02:25:41 (GMT)
committerhobbs <hobbs>2003-02-18 02:25:41 (GMT)
commit4ab5c4158044ba81cf3aa93c71d446fddd9c7ca5 (patch)
tree4897dca0fb72c73e8c8bee4e5d6b292195b07662 /tests
parentd86b1af8bec78fdbcc8bf65bc205fd287e19fd5d (diff)
downloadtcl-4ab5c4158044ba81cf3aa93c71d446fddd9c7ca5.zip
tcl-4ab5c4158044ba81cf3aa93c71d446fddd9c7ca5.tar.gz
tcl-4ab5c4158044ba81cf3aa93c71d446fddd9c7ca5.tar.bz2
* generic/tclExecute.c (TclExecuteByteCode INST_STR_MATCH):
* generic/tclCmdMZ.c (Tcl_StringObjCmd STR_MATCH): * generic/tclUtf.c (TclUniCharMatch): * generic/tclInt.decls: add private TclUniCharMatch function that * generic/tclIntDecls.h: does string match on counted unicode * generic/tclStubInit.c: strings. Tcl_UniCharCaseMatch has the * tests/string.test: failing that it can't handle strings or * tests/stringComp.test: patterns with embedded NULLs. Added tests that actually try strings/pats with NULLs. TclUniCharMatch should be TIPed and made public in the next minor version rev.
Diffstat (limited to 'tests')
-rw-r--r--tests/string.test37
-rw-r--r--tests/stringComp.test48
2 files changed, 82 insertions, 3 deletions
diff --git a/tests/string.test b/tests/string.test
index bffb623..ae84010 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: string.test,v 1.35 2002/11/19 02:34:50 hobbs Exp $
+# RCS: @(#) $Id: string.test,v 1.36 2003/02/18 02:25:45 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -895,7 +895,40 @@ test string-11.51 {string match; *, -nocase and UTF-8} {
string match -nocase [binary format I 717316707] \
[binary format I 2028036707]
} 1
-
+test string-11.52 {string match, null char in string} {
+ set out ""
+ set ptn "*abc*"
+ foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
+ lappend out [string match $ptn $elem]
+ }
+ set out
+} {1 1 1 1}
+test string-11.53 {string match, null char in pattern} {
+ 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
+} {1 0 1 0 1}
+test string-11.54 {string match, failure} {
+ set longString ""
+ for {set i 0} {$i < 10} {incr i} {
+ append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
+ }
+ string first $longString 123
+ 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]
+} {0 1 1 1 0 0}
test string-12.1 {string range} {
list [catch {string range} msg] $msg
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 20779e4..14b0107 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -15,7 +15,7 @@
# 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.5 2002/05/29 09:09:00 hobbs Exp $
+# RCS: @(#) $Id: stringComp.test,v 1.6 2003/02/18 02:25:45 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -643,6 +643,52 @@ test string-11.50 {string match, *special case} {
proc foo {} {string match "\\" "\\"}
foo
} 0
+test string-11.51 {string match; *, -nocase and UTF-8} {
+ proc foo {} {string match -nocase [binary format I 717316707] \
+ [binary format I 2028036707]}
+ foo
+} 1
+test string-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 string-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 string-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
## not yet bc