From bdb525738920825ab991f616f84d47352e5bbde4 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Dec 2007 16:19:53 +0000 Subject: merge updates from HEAD --- ChangeLog | 17 ++++++++++++ doc/StrMatch.3 | 20 +++++++------- doc/StringObj.3 | 4 +-- generic/tcl.h | 8 +++++- generic/tclCmdMZ.c | 18 ++++++------- generic/tclExecute.c | 4 +-- generic/tclInt.decls | 16 ++--------- generic/tclInt.h | 11 +++++++- generic/tclIntDecls.h | 30 +++------------------ generic/tclRegexp.c | 26 +++--------------- generic/tclStubInit.c | 4 +-- generic/tclUtil.c | 73 +++++++++++++++++++++++++++++++++++++++++++++------ tests/string.test | 62 ++++++++++++++++++++++++++++++++++++++++++- 13 files changed, 192 insertions(+), 101 deletions(-) diff --git a/ChangeLog b/ChangeLog index dc09943..55b0c7e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2007-12-10 Jeff Hobbs + + * generic/tclUtil.c (TclReToGlob): reduce escapes in conversion + when not necessary + + * generic/tclInt.decls: move TclByteArrayMatch and TclReToGlob + * generic/tclIntDecls.h: to tclInt.h from stubs. + * generic/tclStubInit.c: Add flags var to TclByteArrayMatch for + * generic/tclInt.h: future extensibility + * generic/tcl.h: define TCL_MATCH_EXACT doc for Tcl_StringCaseMatch. + * doc/StrMatch.3: It is compatible with existing usage. + * generic/tclExecute.c (INST_STR_MATCH): flag for TclByteArrayMatch + * generic/tclUtil.c (TclByteArrayMatch, TclStringMatchObj): + * generic/tclRegexp.c (Tcl_RegExpExecObj): + * generic/tclCmdMZ.c (StringMatchCmd): Use TclStringMatchObj + * tests/string.test (11.9.* 11.10.*): more tests + 2007-12-10 Joe English * doc/string.n, doc/UniCharIsAlpha.3: Fix markup errors. diff --git a/doc/StrMatch.3 b/doc/StrMatch.3 index d17c9d0..a00f863 100644 --- a/doc/StrMatch.3 +++ b/doc/StrMatch.3 @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: StrMatch.3,v 1.9.8.1 2007/11/01 16:25:47 dgp Exp $ +'\" RCS: @(#) $Id: StrMatch.3,v 1.9.8.2 2007/12/11 16:19:54 dgp Exp $ '\" .so man.macros -.TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_StringMatch 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern @@ -20,7 +20,7 @@ int \fBTcl_StringMatch\fR(\fIstr\fR, \fIpattern\fR) .sp int -\fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fInocase\fR) +\fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fIflags\fR) .SH ARGUMENTS .AS "const char" *pattern .AP "const char" *str in @@ -28,9 +28,9 @@ String to test. .AP "const char" *pattern in Pattern to match against string. May contain special characters from the set *?\e[]. -.AP int nocase in -Specifies whether the match should be done case-sensitive (0) or -case-insensitive (1). +.AP int flags in +OR-ed combination of match flags, currently only \fBTCL_MATCH_NOCASE\fR. +0 specifies a case-sensitive search. .BE .SH DESCRIPTION @@ -42,10 +42,10 @@ used for matching is the same algorithm used in the \fBstring match\fR Tcl command and is similar to the algorithm used by the C-shell for file name matching; see the Tcl manual entry for details. .PP -In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have -the option to make the matching case-insensitive. If you choose this -(by passing \fBnocase\fR as 1), then the string and pattern are -essentially matched in the lower case. +In \fBTcl_StringCaseMatch\fR, the algorithm is +the same, but you have the option to make the matching case-insensitive. +If you choose this (by passing \fBTCL_MATCH_NOCASE\fR), then the string and +pattern are essentially matched in the lower case. .SH KEYWORDS match, pattern, string diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 95e37e7..774b6ee 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: StringObj.3,v 1.20.8.3 2007/12/10 19:13:40 dgp Exp $ +'\" RCS: @(#) $Id: StringObj.3,v 1.20.8.4 2007/12/11 16:19:54 dgp Exp $ '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendObjToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings +Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings .SH SYNOPSIS .nf \fB#include \fR diff --git a/generic/tcl.h b/generic/tcl.h index 309fa88..36083d0 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.231.2.12 2007/11/21 06:44:31 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.231.2.13 2007/12/11 16:19:54 dgp Exp $ */ #ifndef _TCL @@ -518,6 +518,12 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ /* + * Flag values passed to Tcl_StringCaseMatch. + */ + +#define TCL_MATCH_NOCASE (1<<0) + +/* * Flag values passed to Tcl_GetRegExpFromObj. */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c8a9cb2..cae1e32 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -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: tclCmdMZ.c,v 1.150.2.10 2007/12/04 16:55:53 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.150.2.11 2007/12/11 16:19:54 dgp Exp $ */ #include "tclInt.h" @@ -1974,8 +1974,7 @@ StringMatchCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring1, *ustring2; - int length1, length2, nocase = 0; + int nocase = 0; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); @@ -1983,21 +1982,20 @@ StringMatchCmd( } if (objc == 4) { - const char *string = TclGetStringFromObj(objv[1], &length2); + int length; + const char *string = TclGetStringFromObj(objv[1], &length); - if ((length2 > 1) && - strncmp(string, "-nocase", (size_t) length2) == 0) { - nocase = 1; + if ((length > 1) && + strncmp(string, "-nocase", (size_t) length) == 0) { + nocase = TCL_MATCH_NOCASE; } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); return TCL_ERROR; } } - ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclUniCharMatch(ustring1, length1, ustring2, length2, nocase))); + TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5103ce0..f0d74c1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.285.2.26 2007/12/10 18:32:55 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.27 2007/12/11 16:19:54 dgp Exp $ */ #include "tclInt.h" @@ -4213,7 +4213,7 @@ TclExecuteByteCode( string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1); string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(string1, length1, string2, length2); + match = TclByteArrayMatch(string1, length1, string2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 55274ae..608413b 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.108.2.6 2007/12/10 18:32:56 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.108.2.7 2007/12/11 16:19:55 dgp Exp $ library tcl @@ -701,7 +701,7 @@ declare 172 generic { declare 173 generic { int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen, - CONST Tcl_UniChar *pattern, int ptnLen, int nocase) + CONST Tcl_UniChar *pattern, int ptnLen, int flags) } # added for 8.4.3 @@ -933,18 +933,6 @@ declare 236 generic { void TclBackgroundException(Tcl_Interp *interp, int code) } -# Added for 8.5b3 to improve binary glob match case -declare 237 generic { - int TclByteArrayMatch(const unsigned char *string, int strLen, - const unsigned char *pattern, int ptnLen) -} - -# Added for 8.5b3 to generalize check for RE to glob pattern conversion -declare 238 generic { - int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, - Tcl_DString *dsPtr, int *exactPtr) -} - ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index a06bc2f..e0f716d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.310.2.22 2007/12/10 18:32:56 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.23 2007/12/11 16:19:55 dgp Exp $ */ #ifndef _TCLINT @@ -2422,6 +2422,9 @@ MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(mp_int *bignum); +MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, + int strLen, const unsigned char *pattern, + int ptnLen, int flags); MODULE_SCOPE double TclCeil(mp_int *a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, @@ -2625,6 +2628,8 @@ MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); +MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, @@ -2636,6 +2641,10 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); +MODULE_SCOPE int TclStringMatch(const char *str, int strLen, + const char *pattern, int ptnLen, int flags); +MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, + Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line); diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 899e279..e17987e 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.99.2.6 2007/12/10 18:32:56 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.99.2.7 2007/12/11 16:19:55 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -830,7 +830,7 @@ EXTERN int TclInThreadExit (void); /* 173 */ EXTERN int TclUniCharMatch (CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, - int ptnLen, int nocase); + int ptnLen, int flags); #endif /* Slot 174 is reserved */ #ifndef TclCallVarTraces_TCL_DECLARED @@ -1082,20 +1082,6 @@ EXTERN void TclInitVarHashTable (TclVarHashTable * tablePtr, EXTERN void TclBackgroundException (Tcl_Interp * interp, int code); #endif -#ifndef TclByteArrayMatch_TCL_DECLARED -#define TclByteArrayMatch_TCL_DECLARED -/* 237 */ -EXTERN int TclByteArrayMatch (const unsigned char * string, - int strLen, const unsigned char * pattern, - int ptnLen); -#endif -#ifndef TclReToGlob_TCL_DECLARED -#define TclReToGlob_TCL_DECLARED -/* 238 */ -EXTERN int TclReToGlob (Tcl_Interp * interp, const char * reStr, - int reStrLen, Tcl_DString * dsPtr, - int * exactPtr); -#endif typedef struct TclIntStubs { int magic; @@ -1298,7 +1284,7 @@ typedef struct TclIntStubs { int (*tclCheckInterpTraces) (Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ - int (*tclUniCharMatch) (CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase); /* 173 */ + int (*tclUniCharMatch) (CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int flags); /* 173 */ void *reserved174; int (*tclCallVarTraces) (Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var * varPtr, Var * arrayPtr); /* 176 */ @@ -1362,8 +1348,6 @@ typedef struct TclIntStubs { Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */ void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */ - int (*tclByteArrayMatch) (const unsigned char * string, int strLen, const unsigned char * pattern, int ptnLen); /* 237 */ - int (*tclReToGlob) (Tcl_Interp * interp, const char * reStr, int reStrLen, Tcl_DString * dsPtr, int * exactPtr); /* 238 */ } TclIntStubs; #ifdef __cplusplus @@ -2115,14 +2099,6 @@ extern TclIntStubs *tclIntStubsPtr; #define TclBackgroundException \ (tclIntStubsPtr->tclBackgroundException) /* 236 */ #endif -#ifndef TclByteArrayMatch -#define TclByteArrayMatch \ - (tclIntStubsPtr->tclByteArrayMatch) /* 237 */ -#endif -#ifndef TclReToGlob -#define TclReToGlob \ - (tclIntStubsPtr->tclReToGlob) /* 238 */ -#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index ec7da0b..0816003 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclRegexp.c,v 1.24.2.1 2007/11/12 19:18:20 dgp Exp $ + * RCS: @(#) $Id: tclRegexp.c,v 1.24.2.2 2007/12/11 16:19:56 dgp Exp $ */ #include "tclInt.h" @@ -448,33 +448,15 @@ Tcl_RegExpExecObj( if ((offset == 0) && (nmatches == 0) && (flags == 0) && !(reflags & ~TCL_REG_GLOBOK_FLAGS) && (regexpPtr->globObjPtr != NULL)) { - int match, nocase = (reflags & TCL_REG_NOCASE); + int nocase = (reflags & TCL_REG_NOCASE) ? TCL_MATCH_NOCASE : 0; /* - * Promote based on the type of incoming object. + * Pass to TclStringMatchObj for obj-specific handling. * XXX: Currently doesn't take advantage of exact-ness that * XXX: TclReToGlob tells us about */ - if (textObj->typePtr == &tclStringType) { - Tcl_UniChar *uptn; - int plen; - - udata = Tcl_GetUnicodeFromObj(textObj, &length); - uptn = Tcl_GetUnicodeFromObj(regexpPtr->globObjPtr, &plen); - match = TclUniCharMatch(udata, length, uptn, plen, nocase); - } else if ((textObj->typePtr == &tclByteArrayType) && !nocase) { - unsigned char *data, *ptn; - int plen; - - data = Tcl_GetByteArrayFromObj(textObj, &length); - ptn = Tcl_GetByteArrayFromObj(regexpPtr->globObjPtr, &plen); - match = TclByteArrayMatch(data, length, ptn, plen); - } else { - match = Tcl_StringCaseMatch(TclGetString(textObj), - TclGetString(regexpPtr->globObjPtr), nocase); - } - return match; + return TclStringMatchObj(textObj, regexpPtr->globObjPtr, nocase); } /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 37d1a2e..3e2be97 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.140.2.5 2007/12/10 18:32:56 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.140.2.6 2007/12/11 16:19:56 dgp Exp $ */ #include "tclInt.h" @@ -335,8 +335,6 @@ TclIntStubs tclIntStubs = { TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ TclBackgroundException, /* 236 */ - TclByteArrayMatch, /* 237 */ - TclReToGlob, /* 238 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 9fc9a58..b490e55 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.82.2.5 2007/11/21 06:30:55 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.82.2.6 2007/12/11 16:19:56 dgp Exp $ */ #include "tclInt.h" @@ -1576,7 +1576,8 @@ TclByteArrayMatch( int strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ - int ptnLen) /* Length of Pattern */ + int ptnLen, /* Length of Pattern */ + int flags) { const unsigned char *stringEnd, *patternEnd; unsigned char p; @@ -1632,7 +1633,7 @@ TclByteArrayMatch( } } if (TclByteArrayMatch(string, stringEnd - string, - pattern, patternEnd - pattern)) { + pattern, patternEnd - pattern, 0)) { return 1; } if (string == stringEnd) { @@ -1727,6 +1728,60 @@ TclByteArrayMatch( /* *---------------------------------------------------------------------- * + * TclStringMatchObj -- + * + * See if a particular string matches a particular pattern. + * Allows case insensitivity. This is the generic multi-type handler + * for the various matching algorithms. + * + * Results: + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclStringMatchObj( + Tcl_Obj *strObj, /* string object. */ + Tcl_Obj *ptnObj, /* pattern object. */ + int flags) /* Only TCL_MATCH_NOCASE should be passed or 0. */ +{ + int match, length, plen; + + /* + * Promote based on the type of incoming object. + * XXX: Currently doesn't take advantage of exact-ness that + * XXX: TclReToGlob tells us about + trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); + */ + + if ((strObj->typePtr == &tclStringType)) { + Tcl_UniChar *udata, *uptn; + + udata = Tcl_GetUnicodeFromObj(strObj, &length); + uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); + match = TclUniCharMatch(udata, length, uptn, plen, flags); + } else if ((strObj->typePtr == &tclByteArrayType) && !flags) { + unsigned char *data, *ptn; + + data = Tcl_GetByteArrayFromObj(strObj, &length); + ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); + match = TclByteArrayMatch(data, length, ptn, plen, 0); + } else { + match = Tcl_StringCaseMatch(TclGetString(strObj), + TclGetString(ptnObj), flags); + } + return match; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DStringInit -- * * Initializes a dynamic string, discarding any previous contents of the @@ -3285,17 +3340,19 @@ TclReToGlob( case 'v': *dsStr++ = '\v'; break; - case 'B': + case 'B': case '\\': *dsStr++ = '\\'; *dsStr++ = '\\'; anchorLeft = 0; /* prevent exact match */ break; - case '\\': case '*': case '+': case '?': - case '{': case '}': case '(': case ')': case '[': case ']': - case '.': case '|': case '^': case '$': + case '*': case '[': case ']': case '?': + /* Only add \ where necessary for glob */ *dsStr++ = '\\'; - *dsStr++ = *p; anchorLeft = 0; /* prevent exact match */ + /* fall through */ + case '{': case '}': case '(': case ')': case '+': + case '.': case '|': case '^': case '$': + *dsStr++ = *p; break; default: msg = "invalid escape sequence"; diff --git a/tests/string.test b/tests/string.test index 29dafcf..d7d20f2 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.62.2.6 2007/11/25 06:45:45 dgp Exp $ +# RCS: @(#) $Id: string.test,v 1.62.2.7 2007/12/11 16:19:56 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -887,9 +887,54 @@ test string-11.8 {string match} { test string-11.9 {string match} { string match *3*6*9 0123456789 } 1 +test string-11.9.1 {string match} { + string match *3*6*89 0123456789 +} 1 +test string-11.9.2 {string match} { + string match *3*456*89 0123456789 +} 1 +test string-11.9.3 {string match} { + string match *3*6* 0123456789 +} 1 +test string-11.9.4 {string match} { + string match *3*56* 0123456789 +} 1 +test string-11.9.5 {string match} { + string match *3*456*** 0123456789 +} 1 +test string-11.9.6 {string match} { + string match **3*456** 0123456789 +} 1 +test string-11.9.7 {string match} { + string match *3***456* 0123456789 +} 1 +test string-11.9.8 {string match} { + string match *3***\[456]* 0123456789 +} 1 +test string-11.9.9 {string match} { + string match *3***\[4-6]* 0123456789 +} 1 +test string-11.9.10 {string match} { + string match *3***\[4-6] 0123456789 +} 0 +test string-11.9.11 {string match} { + string match *3***\[4-6] 0123456 +} 1 test string-11.10 {string match} { string match *3*6*9 01234567890 } 0 +test string-11.10.1 {string match} { + string match *3*6*89 01234567890 +} 0 +test string-11.10.2 {string match} { + string match *3*456*89 01234567890 +} 0 +test string-11.10.3 {string match} { + string match **3*456*89 01234567890 +} 0 +test string-11.10.4 {string match} { + string match *3*456***89 01234567890 +} 0 test string-11.11 {string match} { string match a?c abc } 1 @@ -980,6 +1025,21 @@ test string-11.38 {string match case, reverse range} { test string-11.39 {string match, *\ case} { string match {*\abc} abc } 1 +test string-11.39.1 {string match, *\ case} { + string match {*ab\c} abc +} 1 +test string-11.39.2 {string match, *\ case} { + string match {*ab\*} ab* +} 1 +test string-11.39.3 {string match, *\ case} { + string match {*ab\*} abc +} 0 +test string-11.39.4 {string match, *\ case} { + string match {*ab\\*} {ab\c} +} 1 +test string-11.39.5 {string match, *\ case} { + string match {*ab\\*} {ab\*} +} 1 test string-11.40 {string match, *special case} { string match {*[ab]} abc } 0 -- cgit v0.12