summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h8
-rw-r--r--generic/tclCmdMZ.c18
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclInt.decls16
-rw-r--r--generic/tclInt.h11
-rw-r--r--generic/tclIntDecls.h30
-rw-r--r--generic/tclRegexp.c26
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclUtil.c61
9 files changed, 95 insertions, 83 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index db919dc..494e5da 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.245 2007/11/20 20:43:11 dkf Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.246 2007/12/11 02:57:39 hobbs 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 0d3a3a8..da03f5a 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.161 2007/12/03 13:46:28 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.162 2007/12/11 02:57:39 hobbs 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 c8ec537..ff42fef 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.355 2007/12/07 21:24:41 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.356 2007/12/11 02:57:40 hobbs 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 5cca4c2..e90e5d6 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.118 2007/12/10 15:51:15 das Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.119 2007/12/11 02:57:43 hobbs 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 c507ed3..94a56eb 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.356 2007/12/06 19:34:58 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.357 2007/12/11 02:57:43 hobbs 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 8ef0cd9..863b8f3 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.109 2007/12/10 15:51:55 das Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.110 2007/12/11 02:57:44 hobbs 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 d24e9a8..3f064bf 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.26 2007/11/12 02:07:20 hobbs Exp $
+ * RCS: @(#) $Id: tclRegexp.c,v 1.27 2007/12/11 02:57:44 hobbs 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 4fc5e7c..7ce2229 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.147 2007/12/10 15:51:56 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.148 2007/12/11 02:57:44 hobbs 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 09ecc7d..35efcfd 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.93 2007/11/18 21:59:25 dkf Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.94 2007/12/11 02:57:44 hobbs 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
generated by cgit v0.12 at 2024-11-05 13:17:41 (GMT)