diff options
Diffstat (limited to 'generic')
35 files changed, 1437 insertions, 1217 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index e1093e6..20e9575 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -774,10 +774,10 @@ declare 217 generic { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 generic { - int Tcl_ScanElement(CONST char *str, int *flagPtr) + int Tcl_ScanElement(CONST char *src, int *flagPtr) } declare 219 generic { - int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr) + int Tcl_ScanCountedElement(CONST char *src, int length, int *flagPtr) } # Obsolete declare 220 generic { @@ -1093,11 +1093,11 @@ declare 303 generic { } declare 304 generic { int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST VOID *tablePtr, int offset, CONST char *msg, int flags, + CONST void *tablePtr, int offset, CONST char *msg, int flags, int *indexPtr) } declare 305 generic { - VOID *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) + void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) } declare 306 generic { Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1, diff --git a/generic/tcl.h b/generic/tcl.h index fe384c4..015995c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -352,28 +352,30 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# if defined(__WIN32__) && !defined(__CYGWIN__) -# define TCL_LL_MODIFIER "I64" -# else -# define TCL_LL_MODIFIER "ll" -# endif -typedef struct stat Tcl_StatBuf; -# elif defined(__WIN32__) +# if defined(__WIN32__) && !defined(__CYGWIN__) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "L" # else /* __BORLANDC__ */ -# if _MSC_VER < 1400 || !defined(_M_IX86) +# if defined(_WIN64) +typedef struct __stat64 Tcl_StatBuf; +# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) typedef struct _stati64 Tcl_StatBuf; # else -typedef struct _stat64 Tcl_StatBuf; +typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ # define TCL_LL_MODIFIER "I64" # endif /* __BORLANDC__ */ -# else /* __WIN32__ */ +# elif defined(__GNUC__) +# define TCL_WIDE_INT_TYPE long long +# define TCL_LL_MODIFIER "ll" +# if defined(__WIN32__) +typedef struct _stat32i64 Tcl_StatBuf; +# else +typedef struct stat Tcl_StatBuf; +# endif +# else /* ! __WIN32__ && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 36ece2c..71bd45c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3664,6 +3664,7 @@ TclEvalObjvInternal( } } +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { char *a[10]; int i = 0; @@ -3682,6 +3683,7 @@ TclEvalObjvInternal( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); TclDecrRefCount(info); } +#endif /* USE_DTRACE */ /* * Finally, invoke the command's Tcl_ObjCmdProc. @@ -3756,12 +3758,14 @@ TclEvalObjvInternal( (void) Tcl_GetObjResult(interp); } +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_RESULT_ENABLED()) { Tcl_Obj *r; r = Tcl_GetObjResult(interp); TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); } +#endif /* USE_DTRACE */ done: if (savedVarFramePtr) { @@ -4896,8 +4900,7 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) * up by the caller. It knows better than us. */ - if ((!obj->bytes) || ((obj->typePtr == &tclListType) && - ((List *)obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } @@ -5079,61 +5082,50 @@ TclEvalObjEx( * internal rep). */ - if (objPtr->typePtr == &tclListType) { /* is a list... */ - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; - - if (objPtr->bytes == NULL || /* ...without a string rep */ - listRepPtr->canonicalFlag) {/* ...or that is canonical */ - /* - * TIP #280 Structures for tracking lines. As we know that this is - * dynamic execution we ignore the invoker, even if known. - */ + if (TclListObjIsCanonical(objPtr)) { + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + */ - int nelements; - Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); - CmdFrame *eoFramePtr = (CmdFrame *) + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; - - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 + : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = objPtr; - Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); - eoFramePtr->data.eval.path = NULL; - - /* - * TIP #280 We do _not_ compute all the line numbers for the words - * in the command. For the eval of a pure list the most sensible - * choice is to put all words on line 1. Given that we neither - * need memory for them nor compute anything. 'line' is left - * NULL. The two places using this information (TclInfoFrame, and - * TclInitCompileEnv), are special-cased to use the proper line - * number directly instead of accessing the 'line' array. - */ + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; - Tcl_ListObjGetElements(NULL, copyPtr, - &nelements, &elements); + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; - iPtr->cmdFramePtr = eoFramePtr; - result = Tcl_EvalObjv(interp, nelements, elements, - flags); + /* + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. + */ - Tcl_DecrRefCount(copyPtr); - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); - TclStackFree(interp, eoFramePtr); + Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); - goto done; - } - } + iPtr->cmdFramePtr = eoFramePtr; + result = Tcl_EvalObjv(interp, nelements, elements, flags); - if (flags & TCL_EVAL_DIRECT) { + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); + TclStackFree(interp, eoFramePtr); + } else if (flags & TCL_EVAL_DIRECT) { /* * We're not supposed to use the compiler or byte-code interpreter. * Let Tcl_EvalEx evaluate the command directly (and probably more @@ -5293,7 +5285,6 @@ TclEvalObjEx( iPtr->varFramePtr = savedVarFramePtr; } - done: TclDecrRefCount(objPtr); return result; } @@ -6477,16 +6468,16 @@ ExprAbsFunc( goto unChanged; } else if (l == (long)0) { const char *string = objv[1]->bytes; - if (!string) { - /* There is no string representation, so internal one is correct */ - goto unChanged; - } - while (isspace(UCHAR(*string))) { - ++string; - } - if (*string != '-') { - goto unChanged; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } } + goto unChanged; } else if (l == LONG_MIN) { TclBNInitBignumFromLong(&big, l); goto tooLarge; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index b1bf2ab..90d392b 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -436,6 +436,7 @@ FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { ckfree((char *) GET_BYTEARRAY(objPtr)); + objPtr->typePtr = NULL; } /* diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 5579b47..9d3d6d7 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -81,7 +81,7 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ */ #define BODY_OFFSET \ - ((unsigned long) (&((struct mem_header *) 0)->body)) + ((size_t) (&((struct mem_header *) 0)->body)) static int total_mallocs = 0; static int total_frees = 0; @@ -603,7 +603,7 @@ Tcl_DbCkfree( * words on these machines). */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", @@ -682,7 +682,7 @@ Tcl_DbCkrealloc( * See comment from Tcl_DbCkfree before you change the following line. */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { @@ -713,7 +713,7 @@ Tcl_AttemptDbCkrealloc( * See comment from Tcl_DbCkfree before you change the following line. */ - memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 87c5435..13db6d5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1540,7 +1540,6 @@ InfoLoadedCmd( Tcl_Obj *CONST objv[]) /* Argument objects. */ { char *interpName; - int result; if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); @@ -1552,8 +1551,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - result = TclGetLoadedPackages(interp, interpName); - return result; + return TclGetLoadedPackages(interp, interpName); } /* @@ -2403,7 +2401,7 @@ Tcl_LrepeatObjCmd( register Tcl_Obj *CONST objv[]) /* The argument objects. */ { - int elementCount, i, result, totalElems; + int elementCount, i, totalElems; Tcl_Obj *listPtr, **dataArray; List *listRepPtr; @@ -2416,8 +2414,7 @@ Tcl_LrepeatObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); return TCL_ERROR; } - result = TclGetIntFromObj(interp, objv[1], &elementCount); - if (result == TCL_ERROR) { + if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) { return TCL_ERROR; } if (elementCount < 1) { @@ -2432,21 +2429,14 @@ Tcl_LrepeatObjCmd( objc -= 2; objv += 2; - /* - * Final sanity check. Total number of elements must fit in a signed - * integer. We also limit the number of elements to 512M-1 so allocations - * on 32-bit machines are guaranteed to be less than 2GB! [Bug 2130992] - */ + /* Final sanity check. Do not exceed limits on max list length. */ - totalElems = objc * elementCount; - if (totalElems/objc != elementCount || totalElems/elementCount != objc) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); - return TCL_ERROR; - } - if (totalElems >= 0x20000000) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); + if (objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); return TCL_ERROR; } + totalElems = objc * elementCount; /* * Get an empty list object that is allocated large enough to hold each @@ -2454,7 +2444,7 @@ Tcl_LrepeatObjCmd( */ listPtr = Tcl_NewListObj(totalElems, NULL); - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount*objc; dataArray = &listRepPtr->elements; @@ -2639,15 +2629,15 @@ Tcl_LreverseObjCmd( return TCL_OK; } - if (Tcl_IsShared(objv[1])) { + if (Tcl_IsShared(objv[1]) + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - List *listPtr; + List *listRepPtr; - makeNewReversedList: resultObj = Tcl_NewListObj(elemc, NULL); - listPtr = (List *) resultObj->internalRep.twoPtrValue.ptr1; - listPtr->elemCount = elemc; - dataArray = &listPtr->elements; + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { dataArray[j] = elemv[i]; @@ -2656,15 +2646,6 @@ Tcl_LreverseObjCmd( Tcl_SetObjResult(interp, resultObj); } else { - /* - * It is theoretically possible for a list object to have a shared - * internal representation, but be an unshared object. Check for this - * and use the "shared" code if we have that problem. [Bug 1675044] - */ - - if (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1) { - goto makeNewReversedList; - } /* * Not shared, so swap "in place". This relies on Tcl_LOGE above @@ -3763,7 +3744,7 @@ Tcl_LsortObjCmd( int i; resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL); - listRepPtr = (List *) resultPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(resultPtr); newArray = &listRepPtr->elements; if (indices) { for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cf74db5..60a9414 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1621,7 +1621,7 @@ StringIsCmd( */ const char *elemStart, *nextElem; - int lenRemain, elemSize, hasBrace; + int lenRemain, elemSize; register const char *p; string1 = TclGetStringFromObj(objPtr, &length1); @@ -1630,7 +1630,7 @@ StringIsCmd( for (p=string1, lenRemain=length1; lenRemain > 0; p=nextElem, lenRemain=end-nextElem) { if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace)) { + &elemStart, &nextElem, &elemSize, NULL)) { Tcl_Obj *tmpStr; /* @@ -1643,7 +1643,7 @@ StringIsCmd( * if it is the first "element" that has the failure. */ - while (isspace(UCHAR(*p))) { /* INTL: ? */ + while (TclIsSpaceProc(*p)) { p++; } TclNewStringObj(tmpStr, string1, p-string1); @@ -3108,10 +3108,8 @@ StringTrimCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3123,58 +3121,12 @@ StringTrimCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ - - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); return TCL_OK; } @@ -3204,10 +3156,8 @@ StringTrimLCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3219,34 +3169,10 @@ StringTrimLCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } + trim = TclTrimLeft(string1, length1, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim)); return TCL_OK; } @@ -3276,10 +3202,8 @@ StringTrimRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3291,33 +3215,10 @@ StringTrimRCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ - - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } + trim = TclTrimRight(string1, length1, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim)); return TCL_OK; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index ddd2242..f2d1bfb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3907,7 +3907,6 @@ TclCompileSwitchCmd( int savedStackDepth = envPtr->currStackDepth; int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ - int isListedArms = 0; int i, valueIndex; DefineLineInformation; /* TIP #280 */ int* clNext = envPtr->clNext; @@ -4047,89 +4046,40 @@ TclCompileSwitchCmd( */ if (numWords == 1) { - Tcl_DString bodyList; - const char **argv = NULL, *tokenStartPtr, *p; + CONST char *bytes; + int maxLen, numBytes; int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ - int isTokenBraced; - - /* - * Test that we've got a suitable body list as a simple (i.e. braced) - * word, and that the elements of the body are simple words too. This - * is really rather nasty indeed. - */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } + bytes = tokenPtr[1].start; + numBytes = tokenPtr[1].size; - Tcl_DStringInit(&bodyList); - Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, - &argv) != TCL_OK) { - Tcl_DStringFree(&bodyList); - return TCL_ERROR; - } - Tcl_DStringFree(&bodyList); - - /* - * Now we know what the switch arms are, we've got to see whether we - * can synthesize tokens for the arms. First check whether we've got a - * valid number of arms since we can do that now. - */ - - if (numWords == 0 || numWords % 2) { - ckfree((char *) argv); + /* Allocate enough space to work in. */ + maxLen = TclMaxListLength(bytes, numBytes, NULL); + if (maxLen < 2) { return TCL_ERROR; } - - isListedArms = 1; - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyNext = (int **) ckalloc(sizeof(int*) * numWords); - - /* - * Locate the start of the arms within the overall word. - */ + bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen); + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = (int *) ckalloc(sizeof(int) * maxLen); + bodyNext = (int **) ckalloc(sizeof(int*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; - p = tokenStartPtr = tokenPtr[1].start; - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } + numWords = 0; - /* - * TIP #280: Count lines within the literal list. - */ - - for (i=0 ; i<numWords ; i++) { - bodyTokenArray[i].type = TCL_TOKEN_TEXT; - bodyTokenArray[i].start = tokenStartPtr; - bodyTokenArray[i].size = strlen(argv[i]); - bodyTokenArray[i].numComponents = 0; - bodyToken[i] = bodyTokenArray+i; - tokenStartPtr += bodyTokenArray[i].size; - - /* - * Test to see if we have guessed the end of the word correctly; - * if not, we can't feed the real string to the sub-compilation - * engine, and we're then stuck and so have to punt out to doing - * everything at runtime. - */ + while (numBytes > 0) { + CONST char *prevBytes = bytes; + int literal; - if ((isTokenBraced && *(tokenStartPtr++) != '}') || - (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size - && !isspace(UCHAR(*tokenStartPtr)))) { - ckfree((char *) argv); + if (TCL_OK != TclFindElement(NULL, bytes, numBytes, + &(bodyTokenArray[numWords].start), &bytes, + &(bodyTokenArray[numWords].size), &literal) || !literal) { + abort: ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); @@ -4137,48 +4087,30 @@ TclCompileSwitchCmd( return TCL_ERROR; } + bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; + bodyTokenArray[numWords].numComponents = 0; + bodyToken[numWords] = bodyTokenArray + numWords; + /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ - TclAdvanceLines(&bline, p, bodyTokenArray[i].start); + TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); TclAdvanceContinuations (&bline, &clNext, - bodyTokenArray[i].start - envPtr->source); - bodyLines[i] = bline; - bodyNext[i] = clNext; - p = bodyTokenArray[i].start; - - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { - break; - } - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } + bodyTokenArray[numWords].start - envPtr->source); + bodyLines[numWords] = bline; + bodyNext[numWords] = clNext; + TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); + TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source); + + numBytes -= (bytes - prevBytes); + numWords++; } - ckfree((char *) argv); - - /* - * Check that we've parsed everything we thought we were going to - * parse. If not, something odd is going on (I believe it is possible - * to defeat the code above) and we should bail out. - */ - - if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - return TCL_ERROR; + if (numWords % 2) { + goto abort; } - } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. @@ -4205,8 +4137,7 @@ TclCompileSwitchCmd( * traces, etc. */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - tokenPtr->numComponents != 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { ckfree((char *) bodyToken); ckfree((char *) bodyLines); ckfree((char *) bodyNext); @@ -4255,7 +4186,7 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ - if (isListedArms && mode == Switch_Exact && !noCase) { + if (mode == Switch_Exact) { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, jumpToDefault; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f2c4fdc..2d8d58c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -454,12 +454,13 @@ Tcl_ObjType tclByteCodeType = { * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. This function also takes a hook * procedure that will be invoked to perform any needed post processing - * on the compilation results before generating byte codes. + * on the compilation results before generating byte codes. interp is + * compilation context and may not be NULL. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. + * result. * * Side effects: * Frees the old internal representation. If no error occurs, then the @@ -616,6 +617,9 @@ SetByteCodeFromAny( * compiled. Must not be NULL. */ Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ { + if (interp == NULL) { + return TCL_ERROR; + } (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL); return TCL_OK; } diff --git a/generic/tclConfig.c b/generic/tclConfig.c index c91ee64..251868e 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -273,19 +273,13 @@ QueryConfigObjCmd( } if (n) { - List *listRepPtr = (List *) - listPtr->internalRep.twoPtrValue.ptr1; Tcl_DictSearch s; - Tcl_Obj *key, **vals; - int done, i = 0; - - listRepPtr->elemCount = n; - vals = &listRepPtr->elements; + Tcl_Obj *key; + int done; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { - vals[i++] = key; - Tcl_IncrRefCount(key); + Tcl_ListObjAppendElement(NULL, listPtr, key); } } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 46e90ad..b741475 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3432,7 +3432,7 @@ typedef struct TclStubs { void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ #ifdef __WIN32__ /* WIN */ - void *reserved9; + VOID *reserved9; #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ @@ -3441,7 +3441,7 @@ typedef struct TclStubs { void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ #ifdef __WIN32__ /* WIN */ - void *reserved10; + VOID *reserved10; #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ @@ -3606,7 +3606,7 @@ typedef struct TclStubs { int (*tcl_GetOpenFile) (Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ /* WIN */ - void *reserved167; + VOID *reserved167; #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ @@ -3631,7 +3631,7 @@ typedef struct TclStubs { int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ char * (*tcl_JoinPath) (int argc, CONST84 char *CONST *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, CONST char *varName, char *addr, int type); /* 187 */ - void *reserved188; + VOID *reserved188; Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ @@ -3728,7 +3728,7 @@ typedef struct TclStubs { int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ - void *reserved285; + VOID *reserved285; void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (CONST Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 072f3fa..06c5754 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -402,6 +402,7 @@ FreeDictInternalRep( } dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */ + dictPtr->typePtr = NULL; } /* @@ -488,7 +489,7 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else if (numElems > maxFlags) { - Tcl_Panic("UpdateStringOfDict: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); } @@ -503,7 +504,7 @@ UpdateStringOfDict( elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded < 0) { - Tcl_Panic("UpdateStringOfDict: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } flagPtr[i+1] = TCL_DONT_QUOTE_HASH; @@ -511,11 +512,11 @@ UpdateStringOfDict( elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); if (bytesNeeded < 0) { - Tcl_Panic("UpdateStringOfDict: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } if (bytesNeeded > INT_MAX - numElems + 1) { - Tcl_Panic("UpdateStringOfDict: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -571,14 +572,11 @@ SetDictFromAny( Tcl_Interp *interp, Tcl_Obj *objPtr) { - char *string, *s; - const char *elemStart, *nextElem; - int lenRemain, length, elemSize, hasBrace, result, isNew; - char *limit; /* Points just after string's last byte. */ - register const char *p; - register Tcl_Obj *keyPtr, *valuePtr; - Dict *dict; Tcl_HashEntry *hPtr; + int isNew, result; + Dict *dict = (Dict *) ckalloc(sizeof(Dict)); + + InitChainTable(dict); /* * Since lists and dictionaries have very closely-related string @@ -590,28 +588,15 @@ SetDictFromAny( int objc, i; Tcl_Obj **objv; - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } + /* Cannot fail, we already know the Tcl_ObjType is "list". */ + TclListObjGetElements(NULL, objPtr, &objc, &objv); if (objc & 1) { - if (interp != NULL) { - Tcl_SetResult(interp, "missing value to go with key", - TCL_STATIC); - } - return TCL_ERROR; + goto missingValue; } - /* - * Build the hash of key/value pairs. - */ - - dict = (Dict *) ckalloc(sizeof(Dict)); - InitChainTable(dict); for (i=0 ; i<objc ; i+=2) { - /* - * Store key and value in the hash table we're building. - */ - + + /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); @@ -629,106 +614,68 @@ SetDictFromAny( Tcl_SetHashValue(hPtr, objv[i+1]); Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } + } else { + int length; + const char *nextElem = TclGetStringFromObj(objPtr, &length); + const char *limit = (nextElem + length); + + while (nextElem < limit) { + Tcl_Obj *keyPtr, *valuePtr; + const char *elemStart; + int elemSize, literal; + + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + goto errorExit; + } + if (elemStart == limit) { + break; + } + if (nextElem == limit) { + goto missingValue; + } - /* - * Share type-setting code with the string-conversion case. - */ - - goto installHash; - } - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetStringFromObj(objPtr, &length); - limit = (string + length); - - /* - * Allocate a new HashTable that has objects for keys and objects for - * values. - */ - - dict = (Dict *) ckalloc(sizeof(Dict)); - InitChainTable(dict); - for (p = string, lenRemain = length; - lenRemain > 0; - p = nextElem, lenRemain = (limit - nextElem)) { - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - goto errorExit; - } - if (elemStart >= limit) { - break; - } - - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ - - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy(s, elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } - - TclNewObj(keyPtr); - keyPtr->bytes = s; - keyPtr->length = elemSize; - - p = nextElem; - lenRemain = (limit - nextElem); - if (lenRemain <= 0) { - goto missingKey; - } - - result = TclFindElement(interp, p, lenRemain, - &elemStart, &nextElem, &elemSize, &hasBrace); - if (result != TCL_OK) { - TclDecrRefCount(keyPtr); - goto errorExit; - } - if (elemStart >= limit) { - goto missingKey; - } - - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ - - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy((void *) s, (void *) elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); - } + if (literal) { + TclNewStringObj(keyPtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(keyPtr); + keyPtr->bytes = ckalloc((unsigned) elemSize + 1); + keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, + keyPtr->bytes); + } - TclNewObj(valuePtr); - valuePtr->bytes = s; - valuePtr->length = elemSize; + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { + TclDecrRefCount(keyPtr); + goto errorExit; + } - /* - * Store key and value in the hash table we're building. - */ + if (literal) { + TclNewStringObj(valuePtr, elemStart, elemSize); + } else { + /* Avoid double copy */ + TclNewObj(valuePtr); + valuePtr->bytes = ckalloc((unsigned) elemSize + 1); + valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, + valuePtr->bytes); + } - hPtr = CreateChainEntry(dict, keyPtr, &isNew); - if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + /* Store key and value in the hash table we're building. */ + hPtr = CreateChainEntry(dict, keyPtr, &isNew); + if (!isNew) { + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); - TclDecrRefCount(keyPtr); - TclDecrRefCount(discardedValue); + TclDecrRefCount(keyPtr); + TclDecrRefCount(discardedValue); + } + Tcl_SetHashValue(hPtr, valuePtr); + Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - Tcl_SetHashValue(hPtr, valuePtr); - Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */ } - installHash: /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular @@ -743,11 +690,10 @@ SetDictFromAny( objPtr->typePtr = &tclDictType; return TCL_OK; - missingKey: + missingValue: if (interp != NULL) { Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); } - TclDecrRefCount(keyPtr); result = TCL_ERROR; errorExit: diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ad60ed7..2e0d51f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -334,6 +334,7 @@ FreeEncodingIntRep( Tcl_Obj *objPtr) { Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr); + objPtr->typePtr = NULL; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6ef4ac7..dc87d70 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1473,57 +1473,55 @@ TclCompEvalObj( * information. */ - { + if (invoker) { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); if (hePtr) { ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); int redo = 0; + CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - *ctxPtr = *invoker; - - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ - - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ - - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + *ctxPtr = *invoker; - if (word < ctxPtr->nline) { + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ + + TclGetSrcInfoForPc(ctxPtr); + if (ctxPtr->type == TCL_LOCATION_SOURCE) { /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). + * The reference made by 'TclGetSrcInfoForPc' is + * dead. */ - - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + ctxPtr->data.eval.path = NULL; } - - TclStackFree(interp, ctxPtr); } - + + if (word < ctxPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This + * is a difference and requires a recompile (location + * changed from absolute to relative, literal is used + * fixed and through variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ + + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxPtr->type == TCL_LOCATION_SOURCE)); + } + + TclStackFree(interp, ctxPtr); + if (redo) { goto recompileObj; } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6cd641f..2b4977b 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -950,7 +950,7 @@ TclFileAttrsCmd( int result; CONST char ** attributeStrings; Tcl_Obj* objStrings = NULL; - int numObjStrings = -1; + int numObjStrings = -1, didAlloc = 0; Tcl_Obj *filePtr; if (objc < 3) { @@ -983,9 +983,8 @@ TclFileAttrsCmd( Tcl_AppendResult(interp, "could not read \"", TclGetString(filePtr), "\": ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; } - goto end; + return TCL_ERROR; } /* @@ -1003,12 +1002,16 @@ TclFileAttrsCmd( } attributeStrings = (CONST char **) TclStackAlloc(interp, (1+numObjStrings) * sizeof(char*)); + didAlloc = 1; for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStrings[index] = TclGetString(objPtr); } attributeStrings[index] = NULL; + } else if (objStrings != NULL) { + Tcl_Panic("must not update objPtrRef's variable and return non-NULL"); } + if (objc == 0) { /* * Get all attributes. @@ -1069,6 +1072,10 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (didAlloc) { + TclFreeIntRep(objv[0]); + objv[0]->typePtr = NULL; + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1093,6 +1100,10 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (didAlloc) { + TclFreeIntRep(objv[i]); + objv[i]->typePtr = NULL; + } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", TclGetString(objv[i]), "\" missing", NULL); @@ -1107,20 +1118,20 @@ TclFileAttrsCmd( result = TCL_OK; end: - if (numObjStrings != -1) { + if (didAlloc) { /* * Free up the array we allocated. */ TclStackFree(interp, (void *)attributeStrings); + } + if (objStrings != NULL) { /* * We don't need this object that was passed to us any more. */ - if (objStrings != NULL) { - Tcl_DecrRefCount(objStrings); - } + Tcl_DecrRefCount(objStrings); } return result; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 2ece2f4..0f01baa 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10741,6 +10741,9 @@ SetChannelFromAny( ChannelState *statePtr; Interp *interpPtr; + if (interp == NULL) { + return TCL_ERROR; + } if (objPtr->typePtr == &tclChannelType) { /* * The channel is valid until any call to DetachChannel occurs. diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index dcedd4e..3e37f0f 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -303,9 +303,11 @@ SetIndexFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { + if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't convert value to index except via Tcl_GetIndexFromObj API", -1)); + } return TCL_ERROR; } @@ -395,6 +397,7 @@ FreeIndex( Tcl_Obj *objPtr) { ckfree((char *) objPtr->internalRep.otherValuePtr); + objPtr->typePtr = NULL; } /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 6d63164..e30379e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -576,7 +576,7 @@ declare 145 generic { struct AuxDataType *TclGetAuxDataType(char *typeName) } declare 146 generic { - TclHandle TclHandleCreate(VOID *ptr) + TclHandle TclHandleCreate(void *ptr) } declare 147 generic { void TclHandleFree(TclHandle handle) diff --git a/generic/tclInt.h b/generic/tclInt.h index f6ed2d5..1c1e615 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2193,6 +2193,9 @@ typedef struct List { * accomodate all elements. */ } List; +#define LIST_MAX \ + (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) + /* * Macro used to get the elements of a list object. */ @@ -2200,6 +2203,12 @@ typedef struct List { #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) +#define ListSetIntRep(objPtr, listRepPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ + (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ + (listRepPtr)->refCount++, \ + (objPtr)->typePtr = &tclListType + #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -2207,6 +2216,9 @@ typedef struct List { #define ListObjLength(listPtr, len) \ ((len) = ListRepPtr(listPtr)->elemCount) +#define ListObjIsCanonical(listPtr) \ + (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) + #define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ (((listPtr)->typePtr == &tclListType) \ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ @@ -2217,6 +2229,9 @@ typedef struct List { ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) +#define TclListObjIsCanonical(listPtr) \ + (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) + /* * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. @@ -2646,6 +2661,7 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsLocalScalar(const char *src, int len); +MODULE_SCOPE int TclIsSpaceProc(char byte); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, @@ -2669,9 +2685,8 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); -MODULE_SCOPE int TclMarkList(Tcl_Interp *interp, const char *list, - const char *end, int *argcPtr, - const int **argszPtr, const char ***argvPtr); +MODULE_SCOPE int TclMaxListLength(CONST char *bytes, int numBytes, + CONST char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); @@ -2791,6 +2806,10 @@ MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int *clNextOuter, CONST char *outerScript); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); +MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, + const char *trim, int numTrim); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, @@ -3507,6 +3526,13 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); #else /* not PURIFY or USE_THREAD_ALLOC */ +#if defined(USE_TCLALLOC) && USE_TCLALLOC + MODULE_SCOPE void TclFinalizeAllocSubsystem(); + MODULE_SCOPE void TclInitAlloc(); +#else +# define USE_TCLALLOC 0 +#endif + #ifdef TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 3bf181f..fb63ec0 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1054,11 +1054,11 @@ typedef struct TclIntStubs { int magic; struct TclIntStubHooks *hooks; - void *reserved0; - void *reserved1; - void *reserved2; + VOID *reserved0; + VOID *reserved1; + VOID *reserved2; void (*tclAllocateFreeObjects) (void); /* 3 */ - void *reserved4; + VOID *reserved4; int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, CONST char *src, char *dst); /* 7 */ @@ -1067,29 +1067,29 @@ typedef struct TclIntStubs { int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ - void *reserved13; + VOID *reserved13; int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ - void *reserved15; + VOID *reserved15; void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ - void *reserved17; - void *reserved18; - void *reserved19; - void *reserved20; - void *reserved21; + VOID *reserved17; + VOID *reserved18; + VOID *reserved19; + VOID *reserved20; + VOID *reserved21; int (*tclFindElement) (Tcl_Interp *interp, CONST char *listStr, int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, CONST char *procName); /* 23 */ int (*tclFormatInt) (char *buffer, long n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ - void *reserved26; - void *reserved27; + VOID *reserved26; + VOID *reserved27; Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */ - void *reserved29; - void *reserved30; + VOID *reserved29; + VOID *reserved30; CONST char * (*tclGetExtension) (CONST char *name); /* 31 */ int (*tclGetFrame) (Tcl_Interp *interp, CONST char *str, CallFrame **framePtrPtr); /* 32 */ - void *reserved33; + VOID *reserved33; int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ - void *reserved35; + VOID *reserved35; int (*tclGetLong) (Tcl_Interp *interp, CONST char *str, long *longPtr); /* 36 */ int (*tclGetLoadedPackages) (Tcl_Interp *interp, char *targetName); /* 37 */ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, CONST char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, CONST char **simpleNamePtr); /* 38 */ @@ -1097,74 +1097,74 @@ typedef struct TclIntStubs { int (*tclGetOpenMode) (Tcl_Interp *interp, CONST char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ char * (*tclpGetUserHome) (CONST char *name, Tcl_DString *bufferPtr); /* 42 */ - void *reserved43; + VOID *reserved43; int (*tclGuessPackageName) (CONST char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ int (*tclInExit) (void); /* 46 */ - void *reserved47; - void *reserved48; - void *reserved49; + VOID *reserved47; + VOID *reserved48; + VOID *reserved49; void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ - void *reserved52; + VOID *reserved52; int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ - void *reserved56; - void *reserved57; + VOID *reserved56; + VOID *reserved57; Var * (*tclLookupVar) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, CONST char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */ - void *reserved59; + VOID *reserved59; int (*tclNeedSpace) (CONST char *start, CONST char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 63 */ int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 64 */ - void *reserved65; - void *reserved66; - void *reserved67; - void *reserved68; + VOID *reserved65; + VOID *reserved66; + VOID *reserved67; + VOID *reserved68; char * (*tclpAlloc) (unsigned int size); /* 69 */ - void *reserved70; - void *reserved71; - void *reserved72; - void *reserved73; + VOID *reserved70; + VOID *reserved71; + VOID *reserved72; + VOID *reserved73; void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ void (*tclpGetTime) (Tcl_Time *time); /* 77 */ int (*tclpGetTimeZone) (unsigned long time); /* 78 */ - void *reserved79; - void *reserved80; + VOID *reserved79; + VOID *reserved80; char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ - void *reserved82; - void *reserved83; - void *reserved84; - void *reserved85; - void *reserved86; - void *reserved87; + VOID *reserved82; + VOID *reserved83; + VOID *reserved84; + VOID *reserved85; + VOID *reserved86; + VOID *reserved87; char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ - void *reserved90; + VOID *reserved90; void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName); /* 92 */ void (*tclProcDeleteProc) (ClientData clientData); /* 93 */ - void *reserved94; - void *reserved95; + VOID *reserved94; + VOID *reserved95; int (*tclRenameCommand) (Tcl_Interp *interp, CONST char *oldName, CONST char *newName); /* 96 */ void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */ int (*tclServiceIdle) (void); /* 98 */ - void *reserved99; - void *reserved100; + VOID *reserved99; + VOID *reserved100; char * (*tclSetPreInitScript) (char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, CONST char *str, CONST char *proto, int *portPtr); /* 103 */ int (*tclSockMinimumBuffers) (int sock, int size); /* 104 */ - void *reserved105; - void *reserved106; - void *reserved107; + VOID *reserved105; + VOID *reserved106; + VOID *reserved107; void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - void *reserved110; + VOID *reserved110; void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, CONST char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ @@ -1188,13 +1188,13 @@ typedef struct TclIntStubs { void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ struct tm * (*tclpGetDate) (CONST time_t *time, int useGMT); /* 133 */ - void *reserved134; - void *reserved135; - void *reserved136; - void *reserved137; + VOID *reserved134; + VOID *reserved135; + VOID *reserved136; + VOID *reserved137; CONST84_RETURN char * (*tclGetEnv) (CONST char *name, Tcl_DString *valuePtr); /* 138 */ - void *reserved139; - void *reserved140; + VOID *reserved139; + VOID *reserved140; CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ @@ -1208,13 +1208,13 @@ typedef struct TclIntStubs { void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */ void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ - void *reserved154; - void *reserved155; + VOID *reserved154; + VOID *reserved155; void (*tclRegError) (Tcl_Interp *interp, CONST char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, CONST char *varName); /* 157 */ void (*tclSetStartupScriptFileName) (CONST char *filename); /* 158 */ CONST84_RETURN char * (*tclGetStartupScriptFileName) (void); /* 159 */ - void *reserved160; + VOID *reserved160; int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ VOID * (*tclGetInstructionTable) (void); /* 163 */ @@ -1228,32 +1228,32 @@ typedef struct TclIntStubs { 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 flags); /* 173 */ - void *reserved174; + 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 */ void (*tclVarErrMsg) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, CONST char *operation, CONST char *reason); /* 177 */ void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, CONST char*encodingName); /* 178 */ Tcl_Obj * (*tcl_GetStartupScript) (CONST char **encodingNamePtr); /* 179 */ - void *reserved180; - void *reserved181; + VOID *reserved180; + VOID *reserved181; struct tm * (*tclpLocaltime) (CONST time_t *clock); /* 182 */ struct tm * (*tclpGmtime) (CONST time_t *clock); /* 183 */ - void *reserved184; - void *reserved185; - void *reserved186; - void *reserved187; - void *reserved188; - void *reserved189; - void *reserved190; - void *reserved191; - void *reserved192; - void *reserved193; - void *reserved194; - void *reserved195; - void *reserved196; - void *reserved197; + VOID *reserved184; + VOID *reserved185; + VOID *reserved186; + VOID *reserved187; + VOID *reserved188; + VOID *reserved189; + VOID *reserved190; + VOID *reserved191; + VOID *reserved192; + VOID *reserved193; + VOID *reserved194; + VOID *reserved195; + VOID *reserved196; + VOID *reserved197; int (*tclObjGetFrame) (Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr); /* 198 */ - void *reserved199; + VOID *reserved199; int (*tclpObjRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 200 */ int (*tclpObjCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 201 */ int (*tclpObjCreateDirectory) (Tcl_Obj *pathPtr); /* 202 */ @@ -1263,9 +1263,9 @@ typedef struct TclIntStubs { int (*tclpObjStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 206 */ int (*tclpObjAccess) (Tcl_Obj *pathPtr, int mode); /* 207 */ Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */ - void *reserved209; - void *reserved210; - void *reserved211; + VOID *reserved209; + VOID *reserved210; + VOID *reserved211; void (*tclpFindExecutable) (CONST char *argv0); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */ void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */ @@ -1273,11 +1273,11 @@ typedef struct TclIntStubs { void (*tclStackFree) (Tcl_Interp *interp, VOID *freePtr); /* 216 */ int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ - void *reserved219; - void *reserved220; - void *reserved221; - void *reserved222; - void *reserved223; + VOID *reserved219; + VOID *reserved220; + VOID *reserved221; + VOID *reserved222; + VOID *reserved223; TclPlatformType * (*tclGetPlatform) (void); /* 224 */ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ @@ -1291,18 +1291,18 @@ 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 */ - void *reserved237; - void *reserved238; - void *reserved239; - void *reserved240; - void *reserved241; - void *reserved242; + VOID *reserved237; + VOID *reserved238; + VOID *reserved239; + VOID *reserved240; + VOID *reserved241; + VOID *reserved242; void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ - void *reserved244; - void *reserved245; - void *reserved246; - void *reserved247; - void *reserved248; + VOID *reserved244; + VOID *reserved245; + VOID *reserved246; + VOID *reserved247; + VOID *reserved248; char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ } TclIntStubs; diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index c616671..3c03015 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -381,7 +381,7 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void *reserved5; + VOID *reserved5; TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ @@ -398,27 +398,27 @@ typedef struct TclIntPlatStubs { struct servent * (*tclWinGetServByName) (CONST char *nm, CONST char *proto); /* 2 */ int (*tclWinGetSockOpt) (int s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ - void *reserved5; + VOID *reserved5; u_short (*tclWinNToHS) (u_short ns); /* 6 */ int (*tclWinSetSockOpt) (int s, int level, int optname, CONST char FAR *optval, int optlen); /* 7 */ unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ - void *reserved10; + VOID *reserved10; void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ - void *reserved16; - void *reserved17; + VOID *reserved16; + VOID *reserved17; TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (VOID *hProcess, unsigned long id); /* 20 */ - void *reserved21; + VOID *reserved21; TclFile (*tclpCreateTempFile) (CONST char *contents); /* 22 */ char * (*tclpGetTZName) (int isdst); /* 23 */ char * (*tclWinNoBackslash) (char *path); /* 24 */ - void *reserved25; + VOID *reserved25; void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ @@ -430,7 +430,7 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - void *reserved5; + VOID *reserved5; TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ @@ -711,5 +711,7 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclpLocaltime_unix +#undef TclpGmtime_unix #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3c48a2f..17aa256 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -17,7 +17,9 @@ * Prototypes for functions defined later in this file: */ -static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); +static List * AttemptNewList(Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[], int p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -49,16 +51,16 @@ Tcl_ObjType tclListType = { * * NewListIntRep -- * - * If objc>0 and objv!=NULL, this function creates a list internal rep - * with objc elements given in the array objv. If objc>0 and objv==NULL - * it creates the list internal rep of a list with 0 elements, where - * enough space has been preallocated to store objc elements. If objc<=0, - * it returns NULL. + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. Flag value "p" indicates + * how to behave on failure. * * Results: - * A new List struct is returned. If objc<=0 or if the allocation fails - * for lack of memory, NULL is returned. The list returned has refCount - * 0. + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. * * Side effects: * The ref counts of the elements in objv are incremented since the @@ -70,12 +72,13 @@ Tcl_ObjType tclListType = { static List * NewListIntRep( int objc, - Tcl_Obj *CONST objv[]) + Tcl_Obj *CONST objv[], + int p) { List *listRepPtr; if (objc <= 0) { - return NULL; + Tcl_Panic("NewListIntRep: expects postive element count"); } /* @@ -85,13 +88,21 @@ NewListIntRep( * requires API changes to fix. See [Bug 219196] for a discussion. */ - if ((size_t)objc > INT_MAX/sizeof(Tcl_Obj *)) { + if ((size_t)objc > LIST_MAX) { + if (p) { + Tcl_Panic("max length of a Tcl list (%d elements) exceeded", + LIST_MAX); + } return NULL; } listRepPtr = (List *) attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); if (listRepPtr == NULL) { + if (p) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))); + } return NULL; } @@ -118,6 +129,50 @@ NewListIntRep( /* *---------------------------------------------------------------------- * + * AttemptNewList -- + * + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +static List * +AttemptNewList( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + List *listRepPtr = NewListIntRep(objc, objv, 0); + + if (interp != NULL && listRepPtr == NULL) { + if (objc > LIST_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list creation failed: unable to alloc %u bytes", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))))); + } + } + return listRepPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewListObj -- * * This function is normally called when not debugging: i.e., when @@ -172,21 +227,14 @@ Tcl_NewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; - + ListSetIntRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -244,20 +292,14 @@ Tcl_DbNewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; + ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -326,14 +368,8 @@ Tcl_SetListObj( */ if (objc > 0) { - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); - } - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; - listRepPtr->refCount++; + listRepPtr = NewListIntRep(objc, objv, 1); + ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; @@ -424,30 +460,19 @@ Tcl_ListObjGetElements( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - /* - * Don't get the string version of a dictionary; that transformation - * is not lossy, but is expensive. - */ - - if (listPtr->typePtr == &tclDictType) { - (void) Tcl_DictObjSize(NULL, listPtr, &length); - } else { - (void) TclGetStringFromObj(listPtr, &length); - } - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -551,21 +576,19 @@ Tcl_ListObjAppendElement( Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; @@ -587,9 +610,9 @@ Tcl_ListObjAppendElement( List *oldListRepPtr = listRepPtr; Tcl_Obj **oldElems; - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } oldElems = &oldListRepPtr->elements; elemPtrs = &listRepPtr->elements; @@ -662,21 +685,19 @@ Tcl_ListObjIndex( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -717,21 +738,19 @@ Tcl_ListObjLength( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -792,10 +811,7 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - int length; - - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { if (objc) { Tcl_SetListObj(listPtr, objc, NULL); } else { @@ -818,7 +834,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -884,9 +900,9 @@ Tcl_ListObjReplace( newMax = listRepPtr->maxElemCount; } - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; @@ -1339,8 +1355,10 @@ TclLsetFlat( if (index < 0 || index >= elemCount) { /* ...the index points outside the sublist. */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + } break; } @@ -1488,12 +1506,13 @@ TclListObjSetElement( Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } if (listPtr->typePtr != &tclListType) { - int length, result; + int result; - (void) TclGetStringFromObj(listPtr, &length); - if (!length) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + if (listPtr->bytes == tclEmptyStringRep) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + } return TCL_ERROR; } result = SetListFromAny(interp, listPtr); @@ -1502,7 +1521,7 @@ TclListObjSetElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; @@ -1527,9 +1546,9 @@ TclListObjSetElement( Tcl_Obj **oldElemPtrs = elemPtrs; int i; - listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); + listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL); if (listRepPtr == NULL) { - Tcl_Panic("Not enough memory to allocate list"); + return TCL_ERROR; } listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; elemPtrs = &listRepPtr->elements; @@ -1587,22 +1606,21 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj **elemPtrs = &listRepPtr->elements; - register Tcl_Obj *objPtr; - int numElems = listRepPtr->elemCount; - int i; + List *listRepPtr = ListRepPtr(listPtr); if (--listRepPtr->refCount <= 0) { + Tcl_Obj **elemPtrs = &listRepPtr->elements; + int i, numElems = listRepPtr->elemCount; + for (i = 0; i < numElems; i++) { - objPtr = elemPtrs[i]; - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtrs[i]); } ckfree((char *) listRepPtr); } listPtr->internalRep.twoPtrValue.ptr1 = NULL; listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = NULL; } /* @@ -1627,12 +1645,9 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(srcPtr); - listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclListType; + ListSetIntRep(copyPtr, listRepPtr); } /* @@ -1659,14 +1674,8 @@ SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - char *string, *s; - const char *elemStart, *nextElem; - int lenRemain, length, estCount, elemSize, hasBrace, i, j, result; - const char *limit; /* Points just after string's last byte. */ - register const char *p; - register Tcl_Obj **elemPtrs; - register Tcl_Obj *elemPtr; List *listRepPtr; + Tcl_Obj **elemPtrs; /* * Dictionaries are a special case; they have a string representation such @@ -1691,11 +1700,8 @@ SetListFromAny( */ Tcl_DictObjSize(NULL, objPtr, &size); - listRepPtr = NewListIntRep(size > 0 ? 2*size : 1, NULL); + listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); if (!listRepPtr) { - Tcl_SetResult(interp, - "insufficient memory to allocate list working space", - TCL_STATIC); return TCL_ERROR; } listRepPtr->elemCount = 2 * size; @@ -1706,113 +1712,71 @@ SetListFromAny( elemPtrs = &listRepPtr->elements; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); - i = 0; while (!done) { - elemPtrs[i++] = keyPtr; - elemPtrs[i++] = valuePtr; + *elemPtrs++ = keyPtr; + *elemPtrs++ = valuePtr; Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } + } else { + int estCount, length; + const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* - * Swap the representations. + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) list element. */ - goto commitRepresentation; - } - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetStringFromObj(objPtr, &length); - - /* - * Parse the string into separate string objects, and create a List - * structure that points to the element string objects. We use a modified - * version of Tcl_SplitList's implementation to avoid one malloc and a - * string copy for each list element. First, estimate the number of - * elements by counting the number of space characters in the list. - */ - - limit = string + length; - estCount = 1; - for (p = string; p < limit; p++) { - if (isspace(UCHAR(*p))) { /* INTL: ISO space. */ - estCount++; + estCount = TclMaxListLength(nextElem, length, &limit); + estCount += (estCount == 0); /* Smallest List struct holds 1 element. */ + listRepPtr = AttemptNewList(interp, estCount, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } - } - - /* - * Allocate a new List structure with enough room for "estCount" elements. - * Each element is a pointer to a Tcl_Obj with the appropriate string rep. - * The initial "estCount" elements are set using the corresponding "argv" - * strings. - */ + elemPtrs = &listRepPtr->elements; - listRepPtr = NewListIntRep(estCount, NULL); - if (!listRepPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Not enough memory to allocate the list internal rep", -1)); - return TCL_ERROR; - } - elemPtrs = &listRepPtr->elements; + /* Each iteration, parse and store a list element */ + while (nextElem < limit) { + const char *elemStart; + int elemSize, literal; - for (p=string, lenRemain=length, i=0; - lenRemain > 0; - p=nextElem, lenRemain=limit-nextElem, i++) { - result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, - &elemSize, &hasBrace); - if (result != TCL_OK) { - for (j = 0; j < i; j++) { - elemPtr = elemPtrs[j]; - Tcl_DecrRefCount(elemPtr); + if (TCL_OK != TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal)) { + while (--elemPtrs >= &listRepPtr->elements) { + Tcl_DecrRefCount(*elemPtrs); + } + ckfree((char *) listRepPtr); + return TCL_ERROR; + } + if (elemStart == limit) { + break; } - ckfree((char *) listRepPtr); - return result; - } - if (elemStart >= limit) { - break; - } - if (i > estCount) { - Tcl_Panic("SetListFromAny: bad size estimate for list"); - } - /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". - */ + /* TODO: replace panic with error on alloc failure? */ + if (literal) { + TclNewStringObj(*elemPtrs, elemStart, elemSize); + } else { + TclNewObj(*elemPtrs); + (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); + (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, + (*elemPtrs)->bytes); + } - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy(s, elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - TclNewObj(elemPtr); - elemPtr->bytes = s; - elemPtr->length = elemSize; - elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* Since list now holds ref to it. */ + listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } - listRepPtr->elemCount = i; - /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - commitRepresentation: - listRepPtr->refCount++; TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1843,12 +1807,11 @@ UpdateStringOfList( { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; char *elem, *dst; Tcl_Obj **elemPtrs; - const int maxFlags = UINT_MAX / sizeof(int); /* * Mark the list as being canonical; although it will now have a string @@ -1872,9 +1835,8 @@ UpdateStringOfList( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("UpdateStringOfList: size requirement exceeds limits"); } else { + /* We know numElems <= LIST_MAX, so this is safe. */ flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int)); } elemPtrs = &listRepPtr->elements; @@ -1883,11 +1845,11 @@ UpdateStringOfList( elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded < 0) { - Tcl_Panic("UpdateStringOfList: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } if (bytesNeeded > INT_MAX - numElems + 1) { - Tcl_Panic("UpdateStringOfList: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1747c99..5dbffc6 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3007,7 +3007,7 @@ NamespaceCodeCmd( { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register char *arg, *p; + register char *arg; int length; if (objc != 3) { @@ -3017,21 +3017,17 @@ NamespaceCodeCmd( /* * If "arg" is already a scoped value, then return it directly. + * Take care to only check for scoping in precisely the style that + * [::namespace code] generates it. Anything more forgiving can have + * the effect of failing in namespaces that contain their own custom + " "namespace" command. [Bug 3202171]. */ arg = TclGetStringFromObj(objv[2], &length); - while (*arg == ':') { - arg++; - length--; - } - if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { - for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { - /* empty body: skip over whitespace */ - } - if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { - Tcl_SetObjResult(interp, objv[2]); - return TCL_OK; - } + if (*arg==':' && length > 20 + && strncmp(arg, "::namespace inscope ", 20) == 0) { + Tcl_SetObjResult(interp, objv[2]); + return TCL_OK; } /* @@ -4619,6 +4615,7 @@ FreeNsNameInternalRep( } ckfree((char *) resNamePtr); } + objPtr->typePtr = NULL; } /* @@ -4685,8 +4682,13 @@ SetNsNameFromAny( const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - const char *name = TclGetString(objPtr); + const char *name; + + if (interp == NULL) { + return TCL_ERROR; + } + name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); diff --git a/generic/tclObj.c b/generic/tclObj.c index d084692..5c17df2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4194,6 +4194,7 @@ FreeCmdNameInternalRep( ckfree((char *) resPtr); } } + objPtr->typePtr = NULL; } /* @@ -4264,6 +4265,10 @@ SetCmdNameFromAny( Namespace *currNsPtr; register ResolvedCmdName *resPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Find the Command structure, if any, that describes the command called * "name". Build a ResolvedCmdName that holds a cached pointer to this diff --git a/generic/tclParse.c b/generic/tclParse.c index 158ff42..96c2a10 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -433,7 +433,7 @@ Tcl_ParseCommand( } if (isLiteral) { - int elemCount = 0, code = TCL_OK, nakedbs = 0; + int elemCount = 0, code = TCL_OK, literal = 1; const char *nextElem, *listEnd, *elemStart; /* @@ -455,33 +455,24 @@ Tcl_ParseCommand( */ while (nextElem < listEnd) { - int size, brace; + int size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, - &elemStart, &nextElem, &size, &brace); - if (code != TCL_OK) { + &elemStart, &nextElem, &size, &literal); + if ((code != TCL_OK) || !literal) { break; } - if (!brace) { - const char *s; - - for(s=elemStart;size>0;s++,size--) { - if ((*s)=='\\') { - nakedbs=1; - break; - } - } - } if (elemStart < listEnd) { elemCount++; } } - if ((code != TCL_OK) || nakedbs) { + if ((code != TCL_OK) || !literal) { /* - * Some list element could not be parsed, or contained - * naked backslashes. This means the literal string was - * not in fact a valid nor canonical list. Defer the + * Some list element could not be parsed, or is not + * present as a literal substring of the script. The + * compiler cannot handle list elements that get generated + * by a call to TclCopyAndCollapse(). Defer the * handling of this to compile/eval time, where code is * already in place to report the "attempt to expand a * non-list" error or expand lists that require @@ -505,6 +496,7 @@ Tcl_ParseCommand( * tokens representing the expanded list. */ + CONST char *listStart; int growthNeeded = wordIndex + 2*elemCount - parsePtr->numTokens; parsePtr->numWords += elemCount - 1; @@ -523,14 +515,12 @@ Tcl_ParseCommand( * word value. */ - nextElem = tokenPtr[1].start; - while (isspace(UCHAR(*nextElem))) { - nextElem++; - } + listStart = nextElem = tokenPtr[1].start; while (nextElem < listEnd) { + int quoted; + tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; tokenPtr->numComponents = 1; - tokenPtr->start = nextElem; tokenPtr++; tokenPtr->type = TCL_TOKEN_TEXT; @@ -538,14 +528,13 @@ Tcl_ParseCommand( TclFindElement(NULL, nextElem, listEnd - nextElem, &(tokenPtr->start), &nextElem, &(tokenPtr->size), NULL); - if (tokenPtr->start + tokenPtr->size == listEnd) { - tokenPtr[-1].size = listEnd - tokenPtr[-1].start; - } else { - tokenPtr[-1].size = tokenPtr->start - + tokenPtr->size - tokenPtr[-1].start; - tokenPtr[-1].size += (isspace(UCHAR( - tokenPtr->start[tokenPtr->size])) == 0); - } + + quoted = (tokenPtr->start[-1] == '{' + || tokenPtr->start[-1] == '"') + && tokenPtr->start > listStart; + tokenPtr[-1].start = tokenPtr->start - quoted; + tokenPtr[-1].size = tokenPtr->start + tokenPtr->size + - tokenPtr[-1].start + quoted; tokenPtr++; } @@ -615,6 +604,30 @@ Tcl_ParseCommand( /* *---------------------------------------------------------------------- * + * TclIsSpaceProc -- + * + * Report whether byte is in the set of whitespace characters used by + * Tcl to separate words in scripts or elements in lists. + * + * Results: + * Returns 1, if byte is in the set, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIsSpaceProc( + char byte) +{ + return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n'; +} + +/* + *---------------------------------------------------------------------- + * * ParseWhiteSpace -- * * Scans up to numBytes bytes starting at src, consuming white space @@ -1763,7 +1776,7 @@ Tcl_ParseBraces( openBrace = 0; break; case '#' : - if (openBrace && isspace(UCHAR(src[-1]))) { + if (openBrace && TclIsSpaceProc(src[-1])) { Tcl_AppendResult(parsePtr->interp, ": possible unbalanced brace in comment", NULL); goto error; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index bb2c35d..da3b280 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1154,7 +1154,6 @@ Tcl_FSConvertToPathType( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; } return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); @@ -1173,7 +1172,6 @@ Tcl_FSConvertToPathType( * UpdateStringOfFsPath(pathPtr); * } * FreeFsPathInternalRep(pathPtr); - * pathPtr->typePtr = NULL; * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); * } * } @@ -1963,7 +1961,6 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { return NULL; } @@ -2270,7 +2267,6 @@ TclFSEnsureEpochOk( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2660,6 +2656,7 @@ FreeFsPathInternalRep( } ckfree((char *) fsPathPtr); + pathPtr->typePtr = NULL; } static void diff --git a/generic/tclProc.c b/generic/tclProc.c index 518ddb5..89bd0b9 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -320,8 +320,10 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { + int numBytes; + procArgs +=4; - while(*procArgs != '\0') { + while (*procArgs != '\0') { if (*procArgs != ' ') { goto done; } @@ -332,12 +334,9 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetString(objv[3]); - while (*procBody != '\0') { - if (!isspace(UCHAR(*procBody))) { - goto done; - } - procBody++; + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { + goto done; } /* @@ -1712,6 +1711,7 @@ TclObjInterpProcCore( } #endif /*TCL_COMPILE_DEBUG*/ +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { char *a[10]; int i = 0; @@ -1732,6 +1732,7 @@ TclObjInterpProcCore( TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); TclDecrRefCount(info); } +#endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. @@ -1747,6 +1748,7 @@ TclObjInterpProcCore( procPtr->bodyPtr->internalRep.otherValuePtr; codePtr->refCount++; +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { int l; @@ -1755,6 +1757,7 @@ TclObjInterpProcCore( iPtr->varFramePtr->objc - l, (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); } +#endif /* USE_DTRACE */ result = TclExecuteByteCode(interp, codePtr); if (TCL_DTRACE_PROC_RETURN_ENABLED()) { TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); @@ -1825,6 +1828,7 @@ TclObjInterpProcCore( (void) 0; /* do nothing */ } +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_RESULT_ENABLED()) { Tcl_Obj *r; @@ -1832,6 +1836,7 @@ TclObjInterpProcCore( TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, TclGetString(r), r); } +#endif /* USE_DTRACE */ procDone: /* @@ -2429,6 +2434,7 @@ FreeLambdaInternalRep( TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int @@ -2442,12 +2448,16 @@ SetLambdaFromAny( int objc, result; Proc *procPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Convert objPtr to list type first; if it cannot be converted, or if its * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements(interp, objPtr, &objc, &objv); + result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { TclNewLiteralStringObj(errPtr, "can't interpret \""); Tcl_AppendObjToObj(errPtr, objPtr); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index ed47dc9..d340f4c 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -756,6 +756,7 @@ FreeRegexpInternalRep( if (--(regexpRepPtr->refCount) <= 0) { FreeRegexp(regexpRepPtr); } + objPtr->typePtr = NULL; } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index 556903c..7b58d44 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -959,12 +959,14 @@ ResetObjResult( TclNewObj(objResultPtr); Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; - } else if (objResultPtr->bytes != tclEmptyStringRep) { - if (objResultPtr->bytes != NULL) { - ckfree((char *) objResultPtr->bytes); + } else { + if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes) { + ckfree((char *) objResultPtr->bytes); + } + objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->length = 0; } - objResultPtr->bytes = tclEmptyStringRep; - objResultPtr->length = 0; TclFreeIntRep(objResultPtr); objResultPtr->typePtr = NULL; } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d5c6e9c..e8b7538 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -536,7 +536,7 @@ TclParseNumber( * I, N, and whitespace. */ - if (isspace(UCHAR(c))) { + if (TclIsSpaceProc(c)) { if (flags & TCL_PARSE_NO_WHITESPACE) { goto endgame; } @@ -1050,7 +1050,7 @@ TclParseNumber( } /* FALLTHROUGH */ case sNANPAREN: - if (isspace(UCHAR(c))) { + if (TclIsSpaceProc(c)) { break; } if (numSigDigs < 13) { @@ -1101,7 +1101,7 @@ TclParseNumber( * Accept trailing whitespace. */ - while (len != 0 && isspace(UCHAR(*p))) { + while (len != 0 && TclIsSpaceProc(*p)) { p++; len--; } @@ -2668,7 +2668,7 @@ StrictQuickFormat(double d, /* Number to convert */ */ inline static char* -QuickConversion(double d, /* Number to format */ +QuickConversion(double e, /* Number to format */ int k, /* floor(log10(d)), approximately */ int k_check, /* 0 if k is exact, 1 if it may be too high */ int flags, /* Flags passed to dtoa: @@ -2686,11 +2686,13 @@ QuickConversion(double d, /* Number to format */ char* retval; /* Returned string */ char* end; /* Pointer to the terminal null byte in the * returned string */ + volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ /* * Bring d into the range [1 .. 10) */ - ieps = AdjustRange(&d, k); + ieps = AdjustRange(&e, k); + d = e; /* * If the guessed value of k didn't get d into range, adjust it diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7437ee4..13dda54 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2758,6 +2758,7 @@ TclStringObjReverse( source[i++] = tmp; } Tcl_InvalidateStringRep(objPtr); + stringPtr->allocated = 0; return objPtr; } @@ -3055,6 +3056,7 @@ FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { ckfree((char *) GET_STRING(objPtr)); + objPtr->typePtr = NULL; } /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 520847a..bc29ee6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -31,6 +31,8 @@ #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry #undef Tcl_CreateHashEntry +#define TclpLocaltime_unix TclpLocaltime +#define TclpGmtime_unix TclpGmtime /* * Keep a record of the original Notifier procedures, created in the diff --git a/generic/tclUtf.c b/generic/tclUtf.c index c545e66..00b652e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1526,7 +1526,7 @@ Tcl_UniCharIsSpace( */ if (ch < 0x80) { - return isspace(UCHAR(ch)); /* INTL: ISO space */ + return TclIsSpaceProc((char)ch); } else { category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); return ((SPACE_BITS >> category) & 1); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8e295f4..b00489d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -127,6 +127,309 @@ Tcl_ObjType tclEndOffsetType = { }; /* + * * STRING REPRESENTATION OF LISTS * * * + * + * The next several routines implement the conversions of strings to and + * from Tcl lists. To understand their operation, the rules of parsing + * and generating the string representation of lists must be known. Here + * we describe them in one place. + * + * A list is made up of zero or more elements. Any string is a list if + * it is made up of alternating substrings of element-separating ASCII + * whitespace and properly formatted elements. + * + * The ASCII characters which can make up the whitespace between list + * elements are: + * + * \u0009 \t TAB + * \u000A \n NEWLINE + * \u000B \v VERTICAL TAB + * \u000C \f FORM FEED + * \u000D \r CARRIAGE RETURN + * \u0020 SPACE + * + * NOTE: differences between this and other places where Tcl defines a role + * for "whitespace". + * + * * Unlike command parsing, here NEWLINE is just another whitespace + * character; its role as a command terminator in a script has no + * importance here. + * + * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not + * considered to be a whitespace character. + * + * * Other Unicode whitespace characters (recognized by + * [string is space] or Tcl_UniCharIsSpace()) do not play any role + * as element separators in Tcl lists. + * + * * The NUL byte ought not appear, as it is not in strings properly + * encoded for Tcl, but if it is present, it is not treated as + * separating whitespace, or a string terminator. It is just + * another character in a list element. + * + * The interpretaton of a formatted substring as a list element follows + * rules similar to the parsing of the words of a command in a Tcl script. + * Backslash substitution plays a key role, and is defined exactly as it is + * in command parsing. The same routine, TclParseBackslash() is used in both + * command parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever + * change for command parsing, the interpretation of strings as lists also + * changes. + * + * Backslash substitution replaces an "escape sequence" of one or more + * characters starting with + * \u005c \ BACKSLASH + * with a single character. The one character escape sequent case happens + * only when BACKSLASH is the last character in the string. In all other + * cases, the escape sequence is at least two characters long. + * + * The formatted substrings are interpreted as element values according to + * the following cases: + * + * * If the first character of a formatted substring is + * \u007b { OPEN BRACE + * then the end of the substring is the matching + * \u007d } CLOSE BRACE + * character, where matching is determined by counting nesting levels, + * and not including any brace characters that are contained within a + * backslash escape sequence in the nesting count. Having found the + * matching brace, all characters between the braces are the string + * value of the element. If no matching close brace is found before the + * end of the string, the string is not a Tcl list. If the character + * following the close brace is not an element separating whitespace + * character, or the end of the string, then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a + * Tcl command only in its treatment of the backslash-newline sequence. + * In a list element, the literal characters in the backslash-newline + * sequence become part of the element value. In a script word, + * conversion to a single SPACE character is done. + * + * NOTE: Most list element values can be represented by a formatted + * substring using brace quoting. The exceptions are any element value + * that includes an unbalanced brace not in a backslash escape sequence, + * and any value that ends with a backslash not itself in a backslash + * escape sequence. + * + * * If the first character of a formatted substring is + * \u0022 " QUOTE + * then the end of the substring is the next QUOTE character, not counting + * any QUOTE characters that are contained within a backslash escape + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE + * is not an element separating whitespace character, or the end of the + * string, then the string is not a Tcl list. Having found the limits + * of the substring, the element value is produced by performing backslash + * substitution on the character sequence between the open and close QUOTEs. + * + * NOTE: Any element value can be represented by this style of formatting, + * given suitable choice of backslash escape sequences. + * + * * All other formatted substrings are terminated by the next element + * separating whitespace character in the string. Having found the limits + * of the substring, the element value is produced by performing backslash + * substitution on it. + * + * NOTE: Any element value can be represented by this style of formatting, + * given suitable choice of backslash escape sequences, with one exception. + * The empty string cannot be represented as a list element without the use + * of either braces or quotes to delimit it. + * + * This collection of parsing rules is implemented in the routine + * TclFindElement(). + * + * In order to produce lists that can be parsed by these rules, we need + * the ability to distinguish between characters that are part of a list + * element value from characters providing syntax that define the structure + * of the list. This means that our code that generates lists must at a + * minimum be able to produce escape sequences for the 10 characters + * identified above that have significance to a list parser. + * + * * * CANONICAL LISTS * * * * * + * + * In addition to the basic rules for parsing strings into Tcl lists, there + * are additional properties to be met by the set of list values that are + * generated by Tcl. Such list values are often said to be in "canonical + * form": + * + * * When any canonical list is evaluated as a Tcl script, it is a script + * of either zero commands (an empty list) or exactly one command. The + * command word is exactly the first element of the list, and each argument + * word is exactly one of the following elements of the list. This means + * that any characters that have special meaning during script evaluation + * need special treatment when canonical lists are produced: + * + * * Whitespace between elements may not include NEWLINE. + * * The command terminating character, + * \u003b ; SEMICOLON + * must be BRACEd, QUOTEd, or escaped so that it does not terminate + * the command prematurely. + * * Any of the characters that begin substitutions in scripts, + * \u0024 $ DOLLAR + * \u005b [ OPEN BRACKET + * \u005c \ BACKSLASH + * need to be BRACEd or escaped. + * * In any list where the first character of the first element is + * \u0023 # HASH + * that HASH character must be BRACEd, QUOTEd, or escaped so that it + * does not convert the command into a comment. + * * Any list element that contains the character sequence + * BACKSLASH NEWLINE cannot be formatted with BRACEs. The + * BACKSLASH character must be represented by an escape + * sequence, and unless QUOTEs are used, the NEWLINE must + * be as well. + * + * * It is also guaranteed that one can use a canonical list as a building + * block of a larger script within command substitution, as in this example: + * set script "puts \[[list $cmd $arg]]"; eval $script + * To support this usage, any appearance of the character + * \u005d ] CLOSE BRACKET + * in a list element must be BRACEd, QUOTEd, or escaped. + * + * * Finally it is guaranteed that enclosing a canonical list in braces + * produces a new value that is also a canonical list. This new list has + * length 1, and its only element is the original canonical list. This + * same guarantee also makes it possible to construct scripts where an + * argument word is given a list value by enclosing the canonical form + * of that list in braces: + * set script "puts {[list $one $two $three]}"; eval $script + * This sort of coding was once fairly common, though it's become more + * idiomatic to see the following instead: + * set script [list puts [list $one $two $three]]; eval $script + * In order to support this guarantee, every canonical list must have + * balance when counting those braces that are not in escape sequences. + * + * Within these constraints, the canonical list generation routines + * TclScanElement() and TclConvertElement() attempt to generate the string + * for any list that is easiest to read. When an element value is itself + * acceptable as the formatted substring, it is usually used (CONVERT_NONE). + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) + * is usually preferred over the use of escape sequences (CONVERT_ESCAPE). + * There are some exceptions to both of these preferences for reasons of + * code simplicity, efficiency, and continuation of historical habits. + * Canonical lists never use the QUOTE formatting to delimit their elements + * because that form of quoting does not nest, which makes construction of + * nested lists far too much trouble. Canonical lists always use only a + * single SPACE character for element-separating whitespace. + * + * * * FUTURE CONSIDERATIONS * * * + * + * When a list element requires quoting or escaping due to a CLOSE BRACKET + * character or an internal QUOTE character, a strange formatting mode is + * recommended. For example, if the value "a{b]c}d" is converted by the + * usual modes: + * + * CONVERT_BRACE: a{b]c}d => {a{b]c}d} + * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d + * + * we get perfectly usable formatted list elements. However, this is not + * what Tcl releases have been producing. Instead, we have: + * + * CONVERT_MASK: a{b]c}d => a{b\]c}d + * + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same + * effect can be seen replacing ] with " in this example. There does not + * appear to be any functional or aesthetic purpose for this strange + * additional mode. The sole purpose I can see for preserving it is to + * keep generating the same formatted lists programmers have become accustomed + * to, and perhaps written tests to expect. That is, compatibility only. + * The additional code complexity required to support this mode is significant. + * The lines of code supporting it are delimited in the routines below with + * #if COMPAT directives. This makes it easy to experiment with eliminating + * this formatting mode simply with "#define COMPAT 0" above. I believe + * this is worth considering. + * + * Another consideration is the treatment of QUOTE characters in list elements. + * TclConvertElement() must have the ability to produce the escape sequence + * \" so that when a list element begins with a QUOTE we do not confuse + * that first character with a QUOTE used as list syntax to define list + * structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like + * the way we handle HASH which also needs quoting and escaping only in + * particular situations. Following up this could increase the set of + * list elements that can use the CONVERT_NONE formatting mode. + * + * More speculative is that the demands of canonical list form require brace + * balance for the list as a whole, while the current implementation achieves + * this by establishing brace balance for every element. + * + * Finally, a reminder that the rules for parsing and formatting lists are + * closely tied together with the rules for parsing and evaluating scripts, + * and will need to evolve in sync. + */ + +/* + *---------------------------------------------------------------------- + * + * TclMaxListLength -- + * + * Given 'bytes' pointing to 'numBytes' bytes, scan through them and + * count the number of whitespace runs that could be list element + * separators. If 'numBytes' is -1, scan to the terminating '\0'. + * Not a full list parser. Typically used to get a quick and dirty + * overestimate of length size in order to allocate space for an + * actual list parser to operate with. + * + * Results: + * Returns the largest number of list elements that could possibly + * be in this string, interpreted as a Tcl list. If 'endPtr' is not + * NULL, writes a pointer to the end of the string scanned there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMaxListLength( + CONST char *bytes, + int numBytes, + CONST char **endPtr) +{ + int count = 0; + + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + /* Empty string case - quick exit */ + goto done; + } + + /* No list element before leading white space */ + count += 1 - TclIsSpaceProc(*bytes); + + /* Count white space runs as potential element separators */ + while (numBytes) { + if ((numBytes == -1) && (*bytes == '\0')) { + break; + } + if (TclIsSpaceProc(*bytes)) { + /* Space run started; bump count */ + count++; + do { + bytes++; + numBytes -= (numBytes != -1); + } while (numBytes && TclIsSpaceProc(*bytes)); + if (numBytes == 0) { + break; + } + /* (*bytes) is non-space; return to counting state */ + } + bytes++; + numBytes -= (numBytes != -1); + } + + /* No list element following trailing white space */ + count -= TclIsSpaceProc(bytes[-1]); + + done: + if (endPtr) { + *endPtr = bytes; + } + return count; +} + +/* *---------------------------------------------------------------------- * * TclFindElement -- @@ -146,13 +449,18 @@ Tcl_ObjType tclEndOffsetType = { * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of characters in the element. If + * *sizePtr is filled in with the number of bytes in the element. If * the element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, - * and both *elementPtr and *termPtr will point just after the last - * character in the list. Note: this function does NOT collapse backslash - * sequences. + * and both *elementPtr and *nextPtr will point just after the last + * character in the list. If literalPtr is non-NULL, *literalPtr is set + * to a boolean value indicating whether the substring returned as + * the values of **elementPtr and *sizePtr is the literal value of + * a list element. If not, a call to TclCopyAndCollapse() is needed + * to produce the actual value of the list element. Note: this function + * does NOT collapse backslash sequences, but uses *literalPtr to tell + * callers when it is required for them to do so. * * Side effects: * None. @@ -176,8 +484,12 @@ TclFindElement( * argument (next arg or end of list). */ int *sizePtr, /* If non-zero, fill in with size of * element. */ - int *bracePtr) /* If non-zero, fill in with non-zero/zero to - * indicate that arg was/wasn't in braces. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal list element and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ { CONST char *p = list; CONST char *elemStart; /* Points to first byte of first element. */ @@ -186,6 +498,7 @@ TclFindElement( int inQuotes = 0; int size = 0; /* lint. */ int numChars; + int literal = 1; CONST char *p2; /* @@ -195,7 +508,7 @@ TclFindElement( */ limit = (list + listLength); - while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ + while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } if (p == limit) { /* no element found */ @@ -211,9 +524,6 @@ TclFindElement( p++; } elemStart = p; - if (bracePtr != 0) { - *bracePtr = openBraces; - } /* * Find element's end (a space, close brace, or the end of the string). @@ -243,8 +553,7 @@ TclFindElement( } else if (openBraces == 1) { size = (p - elemStart); p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space. */ + if ((p >= limit) || TclIsSpaceProc(*p)) { goto done; } @@ -254,8 +563,7 @@ TclFindElement( if (interp != NULL) { p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ + while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } @@ -273,6 +581,15 @@ TclFindElement( */ case '\\': + if (openBraces == 0) { + /* + * A backslash sequence not within a brace quoted element + * means the value of the element is different from the + * substring we are parsing. A call to TclCopyAndCollapse() + * is needed to produce the element value. Inform the caller. + */ + literal = 0; + } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; @@ -302,8 +619,7 @@ TclFindElement( if (inQuotes) { size = (p - elemStart); p++; - if ((p >= limit) - || isspace(UCHAR(*p))) { /* INTL: ISO space */ + if ((p >= limit) || TclIsSpaceProc(*p)) { goto done; } @@ -313,8 +629,7 @@ TclFindElement( if (interp != NULL) { p2 = p; - while ((p2 < limit) - && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ + while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } @@ -351,7 +666,7 @@ TclFindElement( } done: - while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ + while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } *elementPtr = elemStart; @@ -359,6 +674,9 @@ TclFindElement( if (sizePtr != 0) { *sizePtr = size; } + if (literalPtr != 0) { + *literalPtr = literal; + } return TCL_OK; } @@ -449,48 +767,31 @@ Tcl_SplitList( CONST char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { - CONST char **argv, *l, *element; + CONST char **argv, *end, *element; char *p; - int length, size, i, result, elSize, brace; + int length, size, i, result, elSize; /* - * Figure out how much space to allocate. There must be enough space for - * both the array of pointers and also for a copy of the list. To estimate - * the number of pointers needed, count the number of space characters in - * the list. + * Allocate enough space to work in. A (CONST char *) for each + * (possible) list element plus one more for terminating NULL, + * plus as many bytes as in the original string value, plus one + * more for a terminating '\0'. Space used to hold element separating + * white space in the original string gets re-purposed to hold '\0' + * characters in the argv array. */ - for (size = 2, l = list; *l != 0; l++) { - if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ - size++; - - /* - * Consecutive space can only count as a single list delimiter. - */ - - while (1) { - char next = *(l + 1); - - if (next == '\0') { - break; - } - ++l; - if (isspace(UCHAR(next))) { /* INTL: ISO space. */ - continue; - } - break; - } - } - } - length = l - list; + size = TclMaxListLength(list, -1, &end) + 1; + length = end - list; argv = (CONST char **) ckalloc((unsigned) ((size * sizeof(char *)) + length + 1)); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { CONST char *prevList = list; + int literal; result = TclFindElement(interp, list, length, &element, &list, - &elSize, &brace); + &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { ckfree((char *) argv); @@ -508,130 +809,18 @@ Tcl_SplitList( return TCL_ERROR; } argv[i] = p; - if (brace) { + if (literal) { memcpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; } else { - TclCopyAndCollapse(elSize, element, p); - p += elSize+1; - } - } - - argv[i] = NULL; - *argvPtr = argv; - *argcPtr = i; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclMarkList -- - * - * Marks the locations within a string where list elements start and - * computes where they end. - * - * Results - * The return value is normally TCL_OK, which means that the list was - * successfully split up. If TCL_ERROR is returned, it means that "list" - * didn't have proper list structure; the interp's result will contain a - * more detailed error message. - * - * *argvPtr will be filled in with the address of an array whose elements - * point to the places where the elements of list start, in order. - * *argcPtr will get filled in with the number of valid elements in the - * array. *argszPtr will get filled in with the address of an array whose - * elements are the lengths of the elements of the list, in order. - * Note: *argvPtr, *argcPtr and *argszPtr are only modified if the - * function returns normally. - * - * Side effects: - * Memory is allocated. - * - *---------------------------------------------------------------------- - */ - -int -TclMarkList( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, no error message is left. */ - CONST char *list, /* Pointer to string with list structure. */ - CONST char *end, /* Pointer to first char after the list. */ - int *argcPtr, /* Pointer to location to fill in with the - * number of elements in the list. */ - CONST int **argszPtr, /* Pointer to place to store length of list - * elements. */ - CONST char ***argvPtr) /* Pointer to place to store pointer to array - * of pointers to list elements. */ -{ - CONST char **argv, *l, *element; - int *argn, length, size, i, result, elSize, brace; - - /* - * Figure out how much space to allocate. There must be enough space for - * the array of pointers and lengths. To estimate the number of pointers - * needed, count the number of whitespace characters in the list. - */ - - for (size=2, l=list ; l!=end ; l++) { - if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ - size++; - - /* - * Consecutive space can only count as a single list delimiter. - */ - - while (1) { - char next = *(l + 1); - - if ((l+1) == end) { - break; - } - ++l; - if (isspace(UCHAR(next))) { /* INTL: ISO space. */ - continue; - } - break; - } - } - } - length = l - list; - argv = (CONST char **) ckalloc((unsigned) size * sizeof(char *)); - argn = (int *) ckalloc((unsigned) size * sizeof(int *)); - - for (i = 0; list != end; i++) { - CONST char *prevList = list; - - result = TclFindElement(interp, list, length, &element, &list, - &elSize, &brace); - length -= (list - prevList); - if (result != TCL_OK) { - ckfree((char *) argv); - ckfree((char *) argn); - return result; + p += 1 + TclCopyAndCollapse(elSize, element, p); } - if (*element == 0) { - break; - } - if (i >= size) { - ckfree((char *) argv); - ckfree((char *) argn); - if (interp != NULL) { - Tcl_SetResult(interp, "internal error in TclMarkList", - TCL_STATIC); - } - return TCL_ERROR; - } - argv[i] = element; - argn[i] = elSize; } argv[i] = NULL; - argn[i] = 0; *argvPtr = argv; - *argszPtr = argn; *argcPtr = i; return TCL_OK; } @@ -646,9 +835,9 @@ TclMarkList( * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of characters that + * The return value is an overestimate of the number of bytes that * will be needed by Tcl_ConvertElement to produce a valid list element - * from string. The word at *flagPtr is filled in with a value needed by + * from src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: @@ -659,11 +848,11 @@ TclMarkList( int Tcl_ScanElement( - register CONST char *string,/* String to convert to list element. */ + register CONST char *src, /* String to convert to list element. */ register int *flagPtr) /* Where to store information to guide * Tcl_ConvertCountedElement. */ { - return Tcl_ScanCountedElement(string, -1, flagPtr); + return Tcl_ScanCountedElement(src, -1, flagPtr); } /* @@ -674,13 +863,13 @@ Tcl_ScanElement( * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned up to the - * first null byte. + * list element. If length is -1, then the string is scanned from src up + * to the first null byte. * * Results: - * The return value is an overestimate of the number of characters that + * The return value is an overestimate of the number of bytes that * will be needed by Tcl_ConvertCountedElement to produce a valid list - * element from string. The word at *flagPtr is filled in with a value + * element from src. The word at *flagPtr is filled in with a value * needed by Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: @@ -691,43 +880,83 @@ Tcl_ScanElement( int Tcl_ScanCountedElement( - CONST char *string, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in string, or -1. */ + CONST char *src, /* String to convert to Tcl list element. */ + int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { int flags = CONVERT_ANY; - int numBytes = TclScanElement(string, length, &flags); + int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } + +/* + *---------------------------------------------------------------------- + * + * TclScanElement -- + * + * This function is a companion function to TclConvertElement. It + * scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a valid Tcl + * list element. If length is -1, then the string is scanned from src up + * to the first null byte. A NULL value for src is treated as an + * empty string. The incoming value of *flagPtr is a report from the + * caller what additional flags it will pass to TclConvertElement(). + * + * Results: + * The recommended formatting mode for the element is determined and + * a value is written to *flagPtr indicating that recommendation. This + * recommendation is combined with the incoming flag values in *flagPtr + * set by the caller to determine how many bytes will be needed by + * TclConvertElement() in which to write the formatted element following + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be + * an overestimate, but so long as the caller passes the same flags + * to TclConvertElement(), it will be large enough. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ int TclScanElement( - CONST char *string, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in string, or -1. */ + CONST char *src, /* String to convert to Tcl list element. */ + int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - CONST char *p = string; - int nestingLevel = 0; - int forbidNone = 0; - int requireEscape = 0; - int extra = 0; - int bytesNeeded; + CONST char *p = src; + int nestingLevel = 0; /* Brace nesting count */ + int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something + needs protection or escape. */ + int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some + * reason bare or brace-quoted form fails. */ + int extra = 0; /* Count of number of extra bytes needed for + * formatted element, assuming we use escape + * sequences in formatting. */ + int bytesNeeded; /* Buffer length computed to complete the + * element formatting in the selected mode. */ #if COMPAT - int preferEscape = 0; - int preferBrace = 0; - int braceCount = 0; + int preferEscape = 0; /* Use preferences to track whether to use */ + int preferBrace = 0; /* CONVERT_MASK mode. */ + int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif - if ((p == NULL) || (length == 0)) { + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + /* Empty string element must be brace quoted. */ *flagPtr = CONVERT_BRACE; return 2; } - if ((*p == '{') || (*p == '"') || ((*p == '\0') && (length == -1))) { + if ((*p == '{') || (*p == '"')) { + /* + * Must escape or protect so leading character of value is not + * misinterpreted as list element delimiting syntax. + */ forbidNone = 1; #if COMPAT preferBrace = 1; @@ -740,16 +969,17 @@ TclScanElement( #if COMPAT braceCount++; #endif - extra++; + extra++; /* Escape '{' => '\{' */ nestingLevel++; break; case '}': #if COMPAT braceCount++; #endif - extra++; + extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { + /* Unbalanced braces! Cannot format with brace quoting. */ requireEscape = 1; } break; @@ -757,7 +987,7 @@ TclScanElement( case '"': #if COMPAT forbidNone = 1; - extra++; + extra++; /* Escapes all just prepend a backslash */ preferEscape = 1; break; #else @@ -773,26 +1003,28 @@ TclScanElement( case '\t': case '\v': forbidNone = 1; - extra++; + extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif break; case '\\': - extra++; + extra++; /* Escape '\' => '\\' */ if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { - requireEscape = 1; + /* Final backslash. Cannot format with brace quoting. */ + requireEscape = 1; break; } if (p[1] == '\n') { - extra++; + extra++; /* Escape newline => '\n', one byte longer */ + /* Backslash newline sequence. Brace quoting not permitted. */ requireEscape = 1; length -= (length > 0); p++; break; } if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { - extra++; + extra++; /* Escape sequences all one byte longer. */ length -= (length > 0); p++; } @@ -814,20 +1046,35 @@ TclScanElement( endOfString: if (nestingLevel != 0) { + /* Unbalanced braces! Cannot format with brace quoting. */ requireEscape = 1; } - bytesNeeded = p - string; + /* We need at least as many bytes as are in the element value... */ + bytesNeeded = p - src; if (requireEscape) { + /* + * We must use escape sequences. Add all the extra bytes needed + * to have room to create them. + */ bytesNeeded += extra; - if ((*string == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* Make room to escape leading #, if needed. */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } *flagPtr = CONVERT_ESCAPE; goto overflowCheck; } if (*flagPtr & CONVERT_ANY) { + /* + * The caller has not let us know what flags it will pass to + * TclConvertElement() so compute the max size we might need for + * any possible choice. Normally the formatting using escape + * sequences is the longer one, and a minimum "extra" value of 2 + * makes sure we don't request too small a buffer in those edge + * cases where that's not true. + */ if (extra < 2) { extra = 2; } @@ -835,12 +1082,26 @@ TclScanElement( *flagPtr |= TCL_DONT_USE_BRACES; } if (forbidNone) { + /* We must request some form of quoting of escaping... */ #if COMPAT if (preferEscape && !preferBrace) { + /* + * If we are quoting solely due to ] or internal " characters + * use the CONVERT_MASK mode where we escape all special + * characters except for braces. "extra" counted space needed + * to escape braces too, so substract "braceCount" to get our + * actual needs. + */ bytesNeeded += (extra - braceCount); - if ((*string == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* Make room to escape leading #, if needed. */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } + /* + * If the caller reports it will direct TclConvertElement() to + * use full escapes on the element, add back the bytes needed to + * escape the braces. + */ if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } @@ -849,18 +1110,26 @@ TclScanElement( } #endif if (*flagPtr & TCL_DONT_USE_BRACES) { + /* + * If the caller reports it will direct TclConvertElement() to + * use escapes, add the extra bytes needed to have room for them. + */ bytesNeeded += extra; - if ((*string == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* Make room to escape leading #, if needed. */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } } else { + /* Add 2 bytes for room for the enclosing braces. */ bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; goto overflowCheck; } - if ((*string == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* So far, no need to quote or escape anything. */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + /* If we need to quote a leading #, make room to enclose in braces. */ bytesNeeded += 2; } *flagPtr = CONVERT_NONE; @@ -934,6 +1203,27 @@ Tcl_ConvertCountedElement( dst[numBytes] = '\0'; return numBytes; } + +/* + *---------------------------------------------------------------------- + * + * TclConvertElement -- + * + * This is a companion function to TclScanElement. Given the + * information produced by TclScanElement, this function converts + * a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element identical + * to src (i.e. if Tcl_SplitList is applied to dst it will produce a + * string identical to src). The return value is a count of the number of + * characters copied (not including the terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ int TclConvertElement( register CONST char *src, /* Source information for list element. */ @@ -944,14 +1234,19 @@ int TclConvertElement( int conversion = flags & CONVERT_MASK; char *p = dst; + /* Let the caller demand we use escape sequences rather than braces. */ if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { conversion = CONVERT_ESCAPE; } - if ((src == NULL) || (length == 0)) { + + /* No matter what the caller demands, empty string must be braced! */ + if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) { src = tclEmptyStringRep; length = 0; conversion = CONVERT_BRACE; } + + /* Escape leading hash as needed and requested. */ if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { if (conversion == CONVERT_ESCAPE) { p[0] = '\\'; @@ -963,6 +1258,8 @@ int TclConvertElement( conversion = CONVERT_BRACE; } } + + /* No escape or quoting needed. Copy the literal string value. */ if (conversion == CONVERT_NONE) { if (length == -1) { /* TODO: INT_MAX overflow? */ @@ -975,6 +1272,8 @@ int TclConvertElement( return length; } } + + /* Formatted string is original string enclosed in braces. */ if (conversion == CONVERT_BRACE) { *p = '{'; p++; @@ -991,8 +1290,10 @@ int TclConvertElement( p++; return p - dst; } + /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ + /* Formatted string is original string converted to escape sequences. */ for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': @@ -1125,7 +1426,7 @@ Tcl_Merge( * the size limits on the formatted string anyway, so just issue * that same panic early. */ - Tcl_Panic("Tcl_Merge: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); } @@ -1133,11 +1434,11 @@ Tcl_Merge( flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); if (bytesNeeded < 0) { - Tcl_Panic("Tcl_Merge: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } if (bytesNeeded > INT_MAX - argc + 1) { - Tcl_Panic("Tcl_Merge: size requirement exceeds limits"); + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; @@ -1198,6 +1499,141 @@ Tcl_Backslash( /* *---------------------------------------------------------------------- * + * TclTrimRight -- + * Takes two counted strings in the Tcl encoding which must both be + * null terminated. Conceptually trims from the right side of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + const char *p = bytes + numBytes; + int pInc; + + if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { + Tcl_Panic("TclTrimRight works only on null-terminated strings"); + } + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + /* Outer loop: iterate over string to be trimmed */ + do { + Tcl_UniChar ch1; + const char *q = trim; + int bytesLeft = numTrim; + + p = Tcl_UtfPrev(p, bytes); + pInc = TclUtfToUniChar(p, &ch1); + + /* Inner loop: scan trim string for match to current character */ + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* No match; trim task done; *p is last non-trimmed char */ + p += pInc; + break; + } + } while (p > bytes); + + return numBytes - (p - bytes); +} + +/* + *---------------------------------------------------------------------- + * + * TclTrimLeft -- + * Takes two counted strings in the Tcl encoding which must both be + * null terminated. Conceptually trims from the left side of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the start of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + const char *p = bytes; + + if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { + Tcl_Panic("TclTrimLeft works only on null-terminated strings"); + } + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + /* Outer loop: iterate over string to be trimmed */ + do { + Tcl_UniChar ch1; + int pInc = TclUtfToUniChar(p, &ch1); + const char *q = trim; + int bytesLeft = numTrim; + + /* Inner loop: scan trim string for match to current character */ + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* No match; trim task done; *p is first non-trimmed char */ + break; + } + + p += pInc; + numBytes -= pInc; + } while (numBytes); + + return p - bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. @@ -1214,56 +1650,77 @@ Tcl_Backslash( *---------------------------------------------------------------------- */ +/* The whitespace characters trimmed during [concat] operations */ +#define CONCAT_WS " \f\v\r\t\n" +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) + char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ CONST char * CONST *argv) /* Array of strings to concatenate. */ { - int totalSize, i; - char *p; - char *result; + int i, needSpace = 0, bytesNeeded = 0; + char *result, *p; - for (totalSize = 1, i = 0; i < argc; i++) { - totalSize += strlen(argv[i]) + 1; - } - result = (char *) ckalloc((unsigned) totalSize); + /* Dispose of the empty result corner case first to simplify later code */ if (argc == 0) { - *result = '\0'; + result = (char *) ckalloc(1); + result[0] = '\0'; return result; } - for (p = result, i = 0; i < argc; i++) { - CONST char *element; - int length; + /* First allocate the result buffer at the size required */ + for (i = 0; i < argc; i++) { + bytesNeeded += strlen(argv[i]); + if (bytesNeeded < 0) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + } + if (bytesNeeded + argc - 1 < 0) { /* - * Clip white space off the front and back of the string to generate a - * neater result, and ignore any empty elements. + * Panic test could be tighter, but not going to bother for + * this legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ + result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); + for (p = result, i = 0; i < argc; i++) { + int trim, elemLength; + const char *element; + element = argv[i]; - while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ - element++; - } - for (length = strlen(element); - (length > 0) - && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ - && ((length < 2) || (element[length-2] != '\\')); - length--) { - /* Null loop body. */ - } - if (length == 0) { + elemLength = strlen(argv[i]); + + /* Trim away the leading whitespace */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + element += trim; + elemLength -= trim; + + /* + * Trim away the trailing whitespace. Do not permit trimming + * to expose a final backslash character. + */ + + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; + + /* If we're left with empty element after trimming, do nothing */ + if (elemLength == 0) { continue; } - memcpy(p, element, (size_t) length); - p += length; - *p = ' '; - p++; - } - if (p != result) { - p[-1] = 0; - } else { - *p = 0; + + /* Append to the result with space if needed */ + if (needSpace) { + *p++ = ' '; + } + memcpy(p, element, (size_t) elemLength); + p += elemLength; + needSpace = 1; } + *p = '\0'; return result; } @@ -1290,35 +1747,25 @@ Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ { - int allocSize, finalSize, length, elemLength, i; - char *p; - char *element; - char *concatStr; + int i, elemLength, needSpace = 0, bytesNeeded = 0; + const char *element; Tcl_Obj *objPtr, *resPtr; /* * Check first to see if all the items are of list type or empty. If so, * we will concat them together as lists, and return a list object. This - * is only valid when the lists have no current string representation, - * since we don't know what the original type was. An original string rep - * may have lost some whitespace info when converted which could be - * important. + * is only valid when the lists are in canonical form. */ for (i = 0; i < objc; i++) { - List *listRepPtr; + int length; objPtr = objv[i]; - if (objPtr->typePtr != &tclListType) { - TclGetString(objPtr); - if (objPtr->length) { - break; - } else { - continue; - } + if (TclListObjIsCanonical(objPtr)) { + continue; } - listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { + Tcl_GetStringFromObj(objPtr, &length); + if (length > 0) { break; } } @@ -1338,7 +1785,7 @@ Tcl_ConcatObj( */ objPtr = objv[i]; - if (objPtr->bytes && !objPtr->length) { + if (objPtr->bytes && objPtr->length == 0) { continue; } TclListObjGetElements(NULL, objPtr, &listc, &listv); @@ -1361,79 +1808,55 @@ Tcl_ConcatObj( * the slow way, using the string representations. */ - allocSize = 0; + /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &length); - if ((element != NULL) && (length > 0)) { - allocSize += (length + 1); + element = TclGetStringFromObj(objv[i], &elemLength); + bytesNeeded += elemLength; + if (bytesNeeded < 0) { + break; } } - if (allocSize == 0) { - allocSize = 1; /* enough for the NULL byte at end */ - } - /* - * Allocate storage for the concatenated result. Note that allocSize is - * one more than the total number of characters, and so includes room for - * the terminating NULL byte. + * Does not matter if this fails, will simply try later to build up + * the string with each Append reallocating as needed with the usual + * string append algorithm. When that fails it will report the error. */ + TclNewObj(resPtr); + Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); + Tcl_SetObjLength(resPtr, 0); - concatStr = ckalloc((unsigned) allocSize); + for (i = 0; i < objc; i++) { + int trim; + + element = TclGetStringFromObj(objv[i], &elemLength); - /* - * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put a - * null byte at the end. - */ + /* Trim away the leading whitespace */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + element += trim; + elemLength -= trim; - finalSize = 0; - if (objc == 0) { - *concatStr = '\0'; - } else { - p = concatStr; - for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) && (UCHAR(*element) < 127) - && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ - element++; - elemLength--; - } + /* + * Trim away the trailing whitespace. Do not permit trimming + * to expose a final backslash character. + */ - /* - * Trim trailing white space. But, be careful not to trim a space - * character if it is preceded by a backslash: in this case it - * could be significant. - */ + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; - while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) - && isspace(UCHAR(element[elemLength-1])) - /* INTL: ISO C space. */ - && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { - elemLength--; - } - if (elemLength == 0) { - continue; /* nothing left of this element */ - } - memcpy(p, element, (size_t) elemLength); - p += elemLength; - *p = ' '; - p++; - finalSize += (elemLength + 1); + /* If we're left with empty element after trimming, do nothing */ + if (elemLength == 0) { + continue; } - if (p != concatStr) { - p[-1] = 0; - finalSize -= 1; /* we overwrote the final ' ' */ - } else { - *p = 0; + + /* Append to the result with space if needed */ + if (needSpace) { + Tcl_AppendToObj(resPtr, " ", 1); } + Tcl_AppendToObj(resPtr, element, elemLength); + needSpace = 1; } - - TclNewObj(objPtr); - objPtr->bytes = concatStr; - objPtr->length = finalSize; - return objPtr; + return resPtr; } /* @@ -2835,7 +3258,7 @@ TclGetIntForIndex( * Leading whitespace is acceptable in an index. */ - while (length && isspace(UCHAR(*bytes))) { /* INTL: ISO space. */ + while (length && TclIsSpaceProc(*bytes)) { bytes++; length--; } @@ -2848,7 +3271,7 @@ TclGetIntForIndex( if ((savedOp != '+') && (savedOp != '-')) { goto parseError; } - if (isspace(UCHAR(opPtr[1]))) { + if (TclIsSpaceProc(opPtr[1])) { goto parseError; } *opPtr = '\0'; @@ -2994,7 +3417,7 @@ SetEndOffsetFromAny( * after "end-" to Tcl_GetInt, then reverse for offset. */ - if (isspace(UCHAR(bytes[4]))) { + if (TclIsSpaceProc(bytes[4])) { return TCL_ERROR; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { @@ -3059,7 +3482,7 @@ TclCheckBadOctal( * zero. Try to generate a meaningful error message. */ - while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + while (TclIsSpaceProc(*p)) { p++; } if (*p == '+' || *p == '-') { @@ -3072,7 +3495,7 @@ TclCheckBadOctal( while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; } - while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + while (TclIsSpaceProc(*p)) { p++; } if (*p == '\0') { diff --git a/generic/tclVar.c b/generic/tclVar.c index 9815469..aaf1cb9 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2554,13 +2554,14 @@ Tcl_AppendObjCmd( /* * Note that we do not need to increase the refCount of the Var * pointers: should a trace delete the variable, the return value - * of TclPtrSetVar will be NULL, and we will not access the - * variable again. + * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not + * access the variable again. */ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1); - if (varValuePtr == NULL) { + if ((varValuePtr == NULL) || + (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { return TCL_ERROR; } } @@ -4775,6 +4776,7 @@ FreeLocalVarName( if (namePtr) { Tcl_DecrRefCount(namePtr); } + objPtr->typePtr = NULL; } static void @@ -4816,6 +4818,7 @@ FreeNsVarName( CleanupVar(varPtr, NULL); } } + objPtr->typePtr = NULL; } static void @@ -4855,6 +4858,7 @@ FreeParsedVarName( TclDecrRefCount(arrayPtr); ckfree(elem); } + objPtr->typePtr = NULL; } static void |