summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2007-11-08 00:50:31 (GMT)
committerhobbs <hobbs>2007-11-08 00:50:31 (GMT)
commit4fca914732d118f26832a92324642c9172452f79 (patch)
tree82266ee0d67a694bbed3a7f04d7ce11f78ad90e0
parentde6a79373ce5c805811210e7375b156dbe68c253 (diff)
downloadtcl-4fca914732d118f26832a92324642c9172452f79.zip
tcl-4fca914732d118f26832a92324642c9172452f79.tar.gz
tcl-4fca914732d118f26832a92324642c9172452f79.tar.bz2
* generic/tclStubInit.c:
* generic/tclInt.decls, generic/tclIntDecls.h: added TclByteArrayMatch * generic/tclUtil.c (TclByteArrayMatch): for efficient glob * generic/tclExecute.c (TclExecuteByteCode): matching of ByteArray Tcl_Objs, used in INST_STR_MATCH. [Bug 1827996]
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclExecute.c11
-rw-r--r--generic/tclInt.decls7
-rw-r--r--generic/tclIntDecls.h13
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclUtil.c191
6 files changed, 226 insertions, 5 deletions
diff --git a/ChangeLog b/ChangeLog
index f3bd07f..80bdd92 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,11 @@
2007-11-07 Jeff Hobbs <jeffh@ActiveState.com>
+ * generic/tclStubInit.c:
+ * generic/tclInt.decls, generic/tclIntDecls.h: added TclByteArrayMatch
+ * generic/tclUtil.c (TclByteArrayMatch): for efficient glob
+ * generic/tclExecute.c (TclExecuteByteCode): matching of ByteArray
+ Tcl_Objs, used in INST_STR_MATCH. [Bug 1827996]
+
* generic/tclIO.c (TclGetsObjBinary): add an efficient binary path
for [gets].
(DoWriteChars): special case for 1-byte channel write.
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 17919db..6cac511 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.339 2007/10/20 02:15:05 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.340 2007/11/08 00:50:31 hobbs Exp $
*/
#include "tclInt.h"
@@ -4063,6 +4063,15 @@ TclExecuteByteCode(
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length1, ustring2, length2,
nocase);
+ } else if ((valuePtr->typePtr == &tclByteArrayType)
+ || (value2Ptr->typePtr == &tclByteArrayType)) {
+ unsigned char *string1, *string2;
+ int length1, length2;
+
+ string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1);
+ string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
+ match = TclByteArrayMatch(string1, length1, string2, length2,
+ nocase);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 57611b9..bf92b7b 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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: tclInt.decls,v 1.114 2007/09/06 18:13:20 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.115 2007/11/08 00:50:31 hobbs Exp $
library tcl
@@ -942,6 +942,11 @@ 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 char *string, int strLen,
+ CONST char *pattern, int ptnLen, int nocase)
+}
##############################################################################
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 157b189..76297aa 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.105 2007/09/06 18:13:20 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.106 2007/11/08 00:50:32 hobbs Exp $
*/
#ifndef _TCLINTDECLS
@@ -1057,6 +1057,12 @@ 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 char * string, int strLen,
+ CONST char * pattern, int ptnLen, int nocase);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1314,6 +1320,7 @@ 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 char * string, int strLen, CONST char * pattern, int ptnLen, int nocase); /* 237 */
} TclIntStubs;
#ifdef __cplusplus
@@ -2047,6 +2054,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclBackgroundException \
(tclIntStubsPtr->tclBackgroundException) /* 236 */
#endif
+#ifndef TclByteArrayMatch
+#define TclByteArrayMatch \
+ (tclIntStubsPtr->tclByteArrayMatch) /* 237 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 15e963b..bfb17fd 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.144 2007/09/06 18:13:23 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.145 2007/11/08 00:50:32 hobbs Exp $
*/
#include "tclInt.h"
@@ -326,6 +326,7 @@ TclIntStubs tclIntStubs = {
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
+ TclByteArrayMatch, /* 237 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 54e8a04..a95f250 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.84 2007/10/28 03:17:00 msofer Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.85 2007/11/08 00:50:32 hobbs Exp $
*/
#include "tclInt.h"
@@ -1553,6 +1553,195 @@ Tcl_StringCaseMatch(
/*
*----------------------------------------------------------------------
*
+ * TclByteArrayMatch --
+ *
+ * See if a particular string matches a particular pattern. Allows case
+ * insensitivity.
+ * Parallels tclUtf.c:TclUniCharMatch, adjusted for char*.
+ *
+ * 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
+TclByteArrayMatch(
+ CONST char *string, /* String. */
+ int strLen, /* Length of String */
+ CONST char *pattern, /* Pattern, which may contain special
+ * characters. */
+ int ptnLen, /* Length of Pattern */
+ int nocase) /* 0 for case sensitive, 1 for insensitive */
+{
+ CONST char *stringEnd, *patternEnd;
+ char p;
+
+ stringEnd = string + strLen;
+ patternEnd = pattern + ptnLen;
+
+ while (1) {
+ /*
+ * See if we're at the end of both the pattern and the string. If so,
+ * we succeeded. If we're at the end of the pattern but not at the end
+ * of the string, we failed.
+ */
+
+ if (pattern == patternEnd) {
+ return (string == stringEnd);
+ }
+ p = *pattern;
+ if ((string == stringEnd) && (p != '*')) {
+ return 0;
+ }
+
+ /*
+ * Check for a "*" as the next pattern character. It matches any
+ * substring. We handle this by skipping all the characters up to the
+ * next matching one in the pattern, and then calling ourselves
+ * recursively for each postfix of string, until either we match or we
+ * reach the end of the string.
+ */
+
+ if (p == '*') {
+ /*
+ * Skip all successive *'s in the pattern.
+ */
+
+ while (*(++pattern) == '*') {
+ /* empty body */
+ }
+ if (pattern == patternEnd) {
+ return 1;
+ }
+ p = *pattern;
+ if (nocase) {
+ p = tolower(p);
+ }
+ while (1) {
+ /*
+ * Optimization for matching - cruise through the string
+ * quickly if the next char in the pattern isn't a special
+ * character.
+ */
+
+ if ((p != '[') && (p != '?') && (p != '\\')) {
+ if (nocase) {
+ while ((string < stringEnd) && (p != *string)
+ && (p != tolower(*string))) {
+ string++;
+ }
+ } else {
+ while ((string < stringEnd) && (p != *string)) {
+ string++;
+ }
+ }
+ }
+ if (TclByteArrayMatch(string, stringEnd - string,
+ pattern, patternEnd - pattern, nocase)) {
+ return 1;
+ }
+ if (string == stringEnd) {
+ return 0;
+ }
+ string++;
+ }
+ }
+
+ /*
+ * Check for a "?" as the next pattern character. It matches any
+ * single character.
+ */
+
+ if (p == '?') {
+ pattern++;
+ string++;
+ continue;
+ }
+
+ /*
+ * Check for a "[" as the next pattern character. It is followed by a
+ * list of characters that are acceptable, or by a range (two
+ * characters separated by "-").
+ */
+
+ if (p == '[') {
+ char ch1, startChar, endChar;
+
+ pattern++;
+ ch1 = (nocase ? tolower(*string) : *string);
+ string++;
+ while (1) {
+ if ((*pattern == ']') || (pattern == patternEnd)) {
+ return 0;
+ }
+ startChar = (nocase ? tolower(*pattern) : *pattern);
+ pattern++;
+ if (*pattern == '-') {
+ pattern++;
+ if (pattern == patternEnd) {
+ return 0;
+ }
+ endChar = (nocase ? tolower(*pattern) : *pattern);
+ pattern++;
+ if (((startChar <= ch1) && (ch1 <= endChar))
+ || ((endChar <= ch1) && (ch1 <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+ break;
+ }
+ } else if (startChar == ch1) {
+ break;
+ }
+ }
+ while (*pattern != ']') {
+ if (pattern == patternEnd) {
+ pattern--;
+ break;
+ }
+ pattern++;
+ }
+ pattern++;
+ continue;
+ }
+
+ /*
+ * If the next pattern character is '\', just strip off the '\' so we
+ * do exact matching on the character that follows.
+ */
+
+ if (p == '\\') {
+ if (++pattern == patternEnd) {
+ return 0;
+ }
+ }
+
+ /*
+ * There's no special character. Just make sure that the next bytes of
+ * each string match.
+ */
+
+ if (nocase) {
+ if (tolower(*string) != tolower(*pattern)) {
+ return 0;
+ }
+ } else if (*string != *pattern) {
+ return 0;
+ }
+ string++;
+ pattern++;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents of the