diff options
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclCmdMZ.c | 273 |
1 files changed, 140 insertions, 133 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 71e2ee5..2300799 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.109 2004/10/06 05:52:21 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.110 2004/10/06 09:28:55 dkf Exp $ */ #include "tclInt.h" @@ -1167,7 +1167,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) { Tcl_UniChar ch; int len; - char *splitChars, *string, *end; + char *splitChars, *stringPtr, *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; @@ -1181,8 +1181,8 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - string = Tcl_GetStringFromObj(objv[1], &stringLen); - end = string + stringLen; + stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); + end = stringPtr + stringLen; listPtr = Tcl_NewObj(); if (stringLen == 0) { @@ -1204,12 +1204,12 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); - for ( ; string < end; string += len) { - len = TclUtfToUniChar(string, &ch); + for ( ; stringPtr < end; stringPtr += len) { + len = TclUtfToUniChar(stringPtr, &ch); /* Assume Tcl_UniChar is an integral type... */ hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { - objPtr = Tcl_NewStringObj(string, len); + objPtr = Tcl_NewStringObj(stringPtr, len); /* Don't need to fiddle with refcount... */ Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { @@ -1227,12 +1227,12 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * char is > 1 byte in length. */ - while (*string && (p = strchr(string, (int) *splitChars)) != NULL) { - objPtr = Tcl_NewStringObj(string, p - string); + while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { + objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); - string = p + 1; + stringPtr = p + 1; } - objPtr = Tcl_NewStringObj(string, end - string); + objPtr = Tcl_NewStringObj(stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { char *element, *p, *splitEnd; @@ -1246,19 +1246,19 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) splitEnd = splitChars + splitCharLen; - for (element = string; string < end; string += len) { - len = TclUtfToUniChar(string, &ch); + for (element = stringPtr; stringPtr < end; stringPtr += len) { + len = TclUtfToUniChar(stringPtr, &ch); for (p = splitChars; p < splitEnd; p += splitLen) { splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { - objPtr = Tcl_NewStringObj(element, string - element); + objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); - element = string + len; + element = stringPtr + len; break; } } } - objPtr = Tcl_NewStringObj(element, string - element); + objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_SetObjResult(interp, listPtr); @@ -2729,8 +2729,8 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, matched, result, splitObjs, numMatchesSaved; - char *string, *pattern; + int i, j, index, mode, result, splitObjs, numMatchesSaved; + char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; @@ -2747,8 +2747,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) matchVarObj = NULL; numMatchesSaved = 0; for (i = 1; i < objc; i++) { - string = Tcl_GetString(objv[i]); - if (string[0] != '-') { + if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, @@ -2856,7 +2855,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (splitObjs) { for (i=0 ; i<objc ; i+=2) { - if (Tcl_GetString(objv[i])[0] == '#') { + if (TclGetString(objv[i])[0] == '#') { Tcl_AppendResult(interp, ", this may be due to a ", "comment incorrectly placed outside of a ", "switch body - see the \"switch\" ", @@ -2874,10 +2873,10 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * check assumes that the list is non-empty! */ - if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) { + if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", - Tcl_GetString(objv[objc-2]), "\"", NULL); + TclGetString(objv[objc-2]), "\"", NULL); return TCL_ERROR; } @@ -2886,15 +2885,12 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * See if the pattern matches the string. */ - pattern = Tcl_GetString(objv[i]); + pattern = TclGetString(objv[i]); - matched = 0; - if ((i == objc - 2) - && (*pattern == 'd') + if ((i == objc - 2) && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { Tcl_Obj *emptyObj = NULL; - matched = 1; /* * If either indexVarObj or matchVarObj are non-NULL, * we're in REGEXP mode but have reached the default @@ -2922,142 +2918,153 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } - numMatchesSaved = 0; + goto matchFound; } else { switch (mode) { case OPT_EXACT: - matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0); + if (strcmp(TclGetString(stringObj), pattern) == 0) { + goto matchFound; + } break; case OPT_GLOB: - matched = Tcl_StringMatch(Tcl_GetString(stringObj), pattern); + if (Tcl_StringMatch(TclGetString(stringObj), pattern)) { + goto matchFound; + } break; case OPT_REGEXP: regExpr = Tcl_GetRegExpFromObj(interp, objv[i], TCL_REG_ADVANCED); if (regExpr == NULL) { return TCL_ERROR; - } - matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0, - numMatchesSaved, 0); - if (matched < 0) { - return TCL_ERROR; + } else { + int matched = Tcl_RegExpExecObj(interp, regExpr, + stringObj, 0, numMatchesSaved, 0); + if (matched < 0) { + return TCL_ERROR; + } else if (matched) { + goto matchFoundRegexp; + } } break; } } - if (matched == 0) { - continue; - } + } + return TCL_OK; - /* - * We are operating in REGEXP mode and we need to store - * information about what we matched in some user-nominated - * arrays. So build the lists of values and indices to write - * here. [TIP#75] - */ + matchFoundRegexp: + /* + * We are operating in REGEXP mode and we need to store + * information about what we matched in some user-nominated + * arrays. So build the lists of values and indices to write + * here. [TIP#75] + */ - if (numMatchesSaved) { - Tcl_RegExpInfo info; - Tcl_Obj *matchesObj, *indicesObj = NULL; + if (numMatchesSaved) { + Tcl_RegExpInfo info; + Tcl_Obj *matchesObj, *indicesObj = NULL; - Tcl_RegExpGetInfo(regExpr, &info); - if (matchVarObj != NULL) { - TclNewObj(matchesObj); - } else { - matchesObj = NULL; - } + Tcl_RegExpGetInfo(regExpr, &info); + if (matchVarObj != NULL) { + TclNewObj(matchesObj); + } else { + matchesObj = NULL; + } + if (indexVarObj != NULL) { + TclNewObj(indicesObj); + } + for (j=0 ; j<=info.nsubs ; j++) { if (indexVarObj != NULL) { - TclNewObj(indicesObj); - } - for (j=0 ; j<=info.nsubs ; j++) { - if (indexVarObj != NULL) { - Tcl_Obj *rangeObjAry[2]; - - rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); - /* - * Never fails; the object is always clean at this point. - */ - Tcl_ListObjAppendElement(NULL, indicesObj, - Tcl_NewListObj(2, rangeObjAry)); - } - if (matchVarObj != NULL) { - Tcl_Obj *substringObj; + Tcl_Obj *rangeObjAry[2]; - substringObj = Tcl_GetRange(stringObj, - info.matches[j].start, info.matches[j].end-1); - /* - * Never fails; the object is always clean at this point. - */ - Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); - } - } - if (indexVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(indicesObj); - /* - * Careful! Check to see if we have allocated the - * list of matched strings; if so (but there was - * an error assigning the indices list) we have a - * potential memory leak because the match list - * has not been written to a variable. Except - * that we'll clean that up right now. - */ - if (matchesObj != NULL) { - Tcl_DecrRefCount(matchesObj); - } - return TCL_ERROR; - } + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); + /* + * Never fails; the object is always clean at this point. + */ + Tcl_ListObjAppendElement(NULL, indicesObj, + Tcl_NewListObj(2, rangeObjAry)); } if (matchVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, - TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_Obj *substringObj; + + substringObj = Tcl_GetRange(stringObj, + info.matches[j].start, info.matches[j].end-1); + /* + * Never fails; the object is always clean at this point. + */ + Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); + } + } + if (indexVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(indicesObj); + /* + * Careful! Check to see if we have allocated the + * list of matched strings; if so (but there was an + * error assigning the indices list) we have a + * potential memory leak because the match list has + * not been written to a variable. Except that we'll + * clean that up right now. + */ + if (matchesObj != NULL) { Tcl_DecrRefCount(matchesObj); - /* - * Unlike above, if indicesObj is non-NULL at this - * point, it will have been written to a variable - * already and will hence not be leaked. - */ - return TCL_ERROR; } + return TCL_ERROR; } } - - /* - * We've got a match. Find a body to execute, skipping bodies - * that are "-". - */ - - for (j = i + 1; ; j += 2) { - if (j >= objc) { + if (matchVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(matchesObj); /* - * This shouldn't happen since we've checked that the - * last body is not a continuation... + * Unlike above, if indicesObj is non-NULL at this + * point, it will have been written to a variable + * already and will hence not be leaked. */ - Tcl_Panic("fall-out when searching for body to match pattern"); - } - if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { - break; + return TCL_ERROR; } } - result = Tcl_EvalObjEx(interp, objv[j], 0); - if (result == TCL_ERROR) { - Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_IncrRefCount(msg); - Tcl_IncrRefCount(errorLine); - TclAppendLimitedToObj(msg, pattern, -1, 50, ""); - Tcl_AppendToObj(msg,"\" arm line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg,")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); - } - return result; } - return TCL_OK; + + matchFound: + /* + * We've got a match. Find a body to execute, skipping bodies that + * are "-". + */ + + for (j = i + 1; ; j += 2) { + if (j >= objc) { + /* + * This shouldn't happen since we've checked that the + * last body is not a continuation... + */ + Tcl_Panic("fall-out when searching for body to match pattern"); + } + if (strcmp(TclGetString(objv[j]), "-") != 0) { + break; + } + } + + result = Tcl_EvalObjEx(interp, objv[j], 0); + + /* + * Generate an error message if necessary. + */ + if (result == TCL_ERROR) { + Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); + Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); + Tcl_IncrRefCount(msg); + Tcl_IncrRefCount(errorLine); + TclAppendLimitedToObj(msg, pattern, -1, 50, ""); + Tcl_AppendToObj(msg,"\" arm line ", -1); + Tcl_AppendObjToObj(msg, errorLine); + Tcl_DecrRefCount(errorLine); + Tcl_AppendToObj(msg,")", -1); + TclAppendObjToErrorInfo(interp, msg); + Tcl_DecrRefCount(msg); + } + return result; } /* |