summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2011-05-10 16:05:48 (GMT)
committerdgp <dgp@users.sourceforge.net>2011-05-10 16:05:48 (GMT)
commitf9dece7738d140a66ebb5d47ee85c4d57249258a (patch)
tree1ca2feda250662282a8e77080fef123d9256b839 /generic
parentb1c2f2c9c6fcb329f1e23f9f5f1ef53c84b01bae (diff)
downloadtcl-f9dece7738d140a66ebb5d47ee85c4d57249258a.zip
tcl-f9dece7738d140a66ebb5d47ee85c4d57249258a.tar.gz
tcl-f9dece7738d140a66ebb5d47ee85c4d57249258a.tar.bz2
Completed patch with mucho comments. Merge 8.5.bug_3173086
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls8
-rw-r--r--generic/tcl.h26
-rw-r--r--generic/tclBasic.c107
-rw-r--r--generic/tclBinary.c1
-rw-r--r--generic/tclCkalloc.c8
-rw-r--r--generic/tclCmdIL.c51
-rw-r--r--generic/tclCmdMZ.c133
-rw-r--r--generic/tclCompCmds.c141
-rw-r--r--generic/tclCompile.c8
-rw-r--r--generic/tclConfig.c12
-rw-r--r--generic/tclDecls.h10
-rw-r--r--generic/tclDictObj.c192
-rw-r--r--generic/tclEncoding.c1
-rw-r--r--generic/tclExecute.c76
-rw-r--r--generic/tclFCmd.c25
-rw-r--r--generic/tclIO.c3
-rw-r--r--generic/tclIndexObj.c3
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h32
-rw-r--r--generic/tclIntDecls.h192
-rw-r--r--generic/tclIntPlatDecls.h18
-rw-r--r--generic/tclListObj.c356
-rw-r--r--generic/tclNamesp.c30
-rw-r--r--generic/tclObj.c5
-rw-r--r--generic/tclParse.c77
-rw-r--r--generic/tclPathObj.c5
-rw-r--r--generic/tclProc.c26
-rw-r--r--generic/tclRegexp.c1
-rw-r--r--generic/tclResult.c12
-rwxr-xr-xgeneric/tclStrToD.c12
-rw-r--r--generic/tclStringObj.c2
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--generic/tclUtf.c2
-rw-r--r--generic/tclUtil.c1065
-rw-r--r--generic/tclVar.c10
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