summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2025-05-26 12:59:04 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2025-05-26 12:59:04 (GMT)
commit05271f5f1347de19b568daa4ac49eccca923ca96 (patch)
tree57b76e599dd2d588c440328588d069ecb33889f2
parent31df7569748f126a4cc0e88854b1019531b5073e (diff)
parentc21ec96ab359f5f26f51e1103bb3671e240be592 (diff)
downloadtcl-core-attemptgetstring.zip
tcl-core-attemptgetstring.tar.gz
tcl-core-attemptgetstring.tar.bz2
Add some more Tcl_Attempt* functionscore-attemptgetstring
-rw-r--r--doc/Object.35
-rw-r--r--doc/ObjectType.33
-rw-r--r--doc/StringObj.38
-rw-r--r--generic/tcl.decls15
-rwxr-xr-xgeneric/tclArithSeries.c16
-rw-r--r--generic/tclCmdMZ.c8
-rw-r--r--generic/tclDecls.h52
-rw-r--r--generic/tclDictObj.c29
-rw-r--r--generic/tclInt.h26
-rw-r--r--generic/tclListObj.c30
-rw-r--r--generic/tclMain.c36
-rw-r--r--generic/tclObj.c124
-rw-r--r--generic/tclStringObj.c95
-rw-r--r--generic/tclStubInit.c10
14 files changed, 400 insertions, 57 deletions
diff --git a/doc/Object.3 b/doc/Object.3
index 5503599..ef91c2f 100644
--- a/doc/Object.3
+++ b/doc/Object.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_BounceRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values
+Tcl_NewObj, Tcl_DuplicateObj, Tcl_AttemptDuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_BounceRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -19,6 +19,9 @@ Tcl_Obj *
Tcl_Obj *
\fBTcl_DuplicateObj\fR(\fIobjPtr\fR)
.sp
+Tcl_Obj *
+\fBTcl_AttemptDuplicateObj\fR(\fIobjPtr\fR)
+.sp
\fBTcl_IncrRefCount\fR(\fIobjPtr\fR)
.sp
\fBTcl_DecrRefCount\fR(\fIobjPtr\fR)
diff --git a/doc/ObjectType.3 b/doc/ObjectType.3
index 1bcf503..a8e5166 100644
--- a/doc/ObjectType.3
+++ b/doc/ObjectType.3
@@ -269,6 +269,9 @@ Tcl routines accepting string values as arguments.
Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR.
Note that \fIupdateStringProc\fRs must allocate
enough storage for the string's bytes and the terminating null byte.
+If the \fIupdateStringProc\fR cannot do that, it must set
+interp->bytes to be NULL (freeing the previous content), and set
+interp->length to the number of bytes it tried to allocate.
.PP
The \fIupdateStringProc\fR for Tcl's built-in double type, for example,
calls Tcl_PrintDouble to write to a buffer of size TCL_DOUBLE_SPACE,
diff --git a/doc/StringObj.3 b/doc/StringObj.3
index df2bcf5..205c1c5 100644
--- a/doc/StringObj.3
+++ b/doc/StringObj.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj, Tcl_IsEmpty \- manipulate Tcl values as strings
+Tcl_NewStringObj, Tcl_AttemptNewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_AttemptSetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj, Tcl_IsEmpty \- manipulate Tcl values as strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -17,11 +17,17 @@ Tcl_Obj *
\fBTcl_NewStringObj\fR(\fIbytes, length\fR)
.sp
Tcl_Obj *
+\fBTcl_AttemptNewStringObj\fR(\fIbytes, length\fR)
+.sp
+Tcl_Obj *
\fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR)
.sp
void
\fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR)
.sp
+char *
+\fBTcl_AttemptSetStringObj\fR(\fIobjPtr, bytes, length\fR)
+.sp
void
\fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 05849fc..3f90629 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -104,6 +104,9 @@ declare 20 {
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
+declare 22 {
+ char *Tcl_DbGetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr, const char *file, int line)
+}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
Tcl_Size numBytes, const char *file, int line)
@@ -193,6 +196,9 @@ declare 55 {
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length)
}
+declare 57 {
+ Tcl_Obj *Tcl_AttemptNewStringObj(const char *bytes, Tcl_Size length)
+}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes)
}
@@ -1038,6 +1044,15 @@ declare 338 {
declare 339 {
Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
+declare 340 {
+ char *Tcl_AttemptGetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr)
+}
+declare 341 {
+ char *Tcl_AttemptSetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
+}
+declare 342 {
+ Tcl_Obj *Tcl_AttemptDuplicateObj(Tcl_Obj *objPtr)
+}
declare 343 {
void Tcl_AlertNotifier(void *clientData)
}
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
index c075369..3f4b98b 100755
--- a/generic/tclArithSeries.c
+++ b/generic/tclArithSeries.c
@@ -1175,9 +1175,7 @@ UpdateStringOfArithSeries(
Tcl_PrintDouble(NULL,d,tmp);
elen = strlen(tmp);
if (bytlen > TCL_SIZE_MAX - elen) {
- /* overflow, todo: check we could use some representation instead of the panic
- * to signal it is too large for string representation, because too heavy */
- Tcl_Panic("UpdateStringOfArithSeries: too large to represent");
+ goto repTooLarge;
}
bytlen += elen;
}
@@ -1188,8 +1186,16 @@ UpdateStringOfArithSeries(
* Pass 2: generate the string repr.
*/
- p = srep = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
- TclOOM(p, bytlen+1);
+ p = srep = TclAttemptInitStringRep(arithSeriesObjPtr, NULL, bytlen);
+ if (!p) {
+ repTooLarge:
+ if (arithSeriesObjPtr->bytes) {
+ Tcl_Free(arithSeriesObjPtr->bytes);
+ arithSeriesObjPtr->bytes = 0;
+ }
+ arithSeriesObjPtr->length = bytlen;
+ return;
+ }
if (!arithSeriesRepPtr->isDouble) {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index ca813d7..1eb37b0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -2681,6 +2681,10 @@ StringEqualCmd(
objv += objc-2;
match = TclStringCmp(objv[0], objv[1], 1, nocase, reqlength);
+ if (match == INT_MIN) {
+ Tcl_AppendResult(interp, "memory allocation error", (char *)NULL);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
return TCL_OK;
}
@@ -2726,6 +2730,10 @@ StringCmpCmd(
objv += objc-2;
match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
+ if (match == INT_MIN) {
+ Tcl_AppendResult(interp, "memory allocation error", (char *)NULL);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match));
return TCL_OK;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 47f6b9a..b9e2ab8 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -107,7 +107,10 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
/* 21 */
EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
-/* Slot 22 is reserved */
+/* 22 */
+EXTERN char * Tcl_DbGetStringFromObj(Tcl_Obj *objPtr,
+ Tcl_Size *lengthPtr, const char *file,
+ int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
Tcl_Size numBytes, const char *file,
@@ -189,7 +192,9 @@ EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]);
EXTERN Tcl_Obj * Tcl_NewObj(void);
/* 56 */
EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length);
-/* Slot 57 is reserved */
+/* 57 */
+EXTERN Tcl_Obj * Tcl_AttemptNewStringObj(const char *bytes,
+ Tcl_Size length);
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr,
Tcl_Size numBytes);
@@ -894,9 +899,14 @@ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src,
Tcl_Size srcLen);
/* 339 */
EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
-/* Slot 340 is reserved */
-/* Slot 341 is reserved */
-/* Slot 342 is reserved */
+/* 340 */
+EXTERN char * Tcl_AttemptGetStringFromObj(Tcl_Obj *objPtr,
+ Tcl_Size *lengthPtr);
+/* 341 */
+EXTERN char * Tcl_AttemptSetStringObj(Tcl_Obj *objPtr,
+ const char *bytes, Tcl_Size length);
+/* 342 */
+EXTERN Tcl_Obj * Tcl_AttemptDuplicateObj(Tcl_Obj *objPtr);
/* 343 */
EXTERN void Tcl_AlertNotifier(void *clientData);
/* 344 */
@@ -1907,7 +1917,7 @@ typedef struct TclStubs {
void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
- void (*reserved22)(void);
+ char * (*tcl_DbGetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr, const char *file, int line); /* 22 */
Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
Tcl_Obj * (*tcl_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
@@ -1942,7 +1952,7 @@ typedef struct TclStubs {
void (*reserved54)(void);
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */
- void (*reserved57)(void);
+ Tcl_Obj * (*tcl_AttemptNewStringObj) (const char *bytes, Tcl_Size length); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */
void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
@@ -2225,9 +2235,9 @@ typedef struct TclStubs {
Tcl_Size (*tcl_UtfToUpper) (char *src); /* 337 */
Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */
Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
- void (*reserved340)(void);
- void (*reserved341)(void);
- void (*reserved342)(void);
+ char * (*tcl_AttemptGetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 340 */
+ char * (*tcl_AttemptSetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 341 */
+ Tcl_Obj * (*tcl_AttemptDuplicateObj) (Tcl_Obj *objPtr); /* 342 */
void (*tcl_AlertNotifier) (void *clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
@@ -2635,7 +2645,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_DbIncrRefCount) /* 20 */
#define Tcl_DbIsShared \
(tclStubsPtr->tcl_DbIsShared) /* 21 */
-/* Slot 22 is reserved */
+#define Tcl_DbGetStringFromObj \
+ (tclStubsPtr->tcl_DbGetStringFromObj) /* 22 */
#define Tcl_DbNewByteArrayObj \
(tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */
#define Tcl_DbNewDoubleObj \
@@ -2696,7 +2707,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_NewObj) /* 55 */
#define Tcl_NewStringObj \
(tclStubsPtr->tcl_NewStringObj) /* 56 */
-/* Slot 57 is reserved */
+#define Tcl_AttemptNewStringObj \
+ (tclStubsPtr->tcl_AttemptNewStringObj) /* 57 */
#define Tcl_SetByteArrayLength \
(tclStubsPtr->tcl_SetByteArrayLength) /* 58 */
#define Tcl_SetByteArrayObj \
@@ -3219,9 +3231,12 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_WriteChars) /* 338 */
#define Tcl_WriteObj \
(tclStubsPtr->tcl_WriteObj) /* 339 */
-/* Slot 340 is reserved */
-/* Slot 341 is reserved */
-/* Slot 342 is reserved */
+#define Tcl_AttemptGetStringFromObj \
+ (tclStubsPtr->tcl_AttemptGetStringFromObj) /* 340 */
+#define Tcl_AttemptSetStringObj \
+ (tclStubsPtr->tcl_AttemptSetStringObj) /* 341 */
+#define Tcl_AttemptDuplicateObj \
+ (tclStubsPtr->tcl_AttemptDuplicateObj) /* 342 */
#define Tcl_AlertNotifier \
(tclStubsPtr->tcl_AlertNotifier) /* 343 */
#define Tcl_ServiceModeHook \
@@ -4010,6 +4025,8 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_GetString(objPtr) \
Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL)
+#define Tcl_AttemptGetString(objPtr) \
+ Tcl_AttemptGetStringFromObj(objPtr, (Tcl_Size *)NULL)
#define Tcl_GetUnicode(objPtr) \
Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL)
#undef Tcl_GetIndexFromObjStruct
@@ -4063,6 +4080,11 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_AttemptRealloc
# define Tcl_AttemptRealloc(x,y) \
(Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__))
+# define Tcl_Alloc(x) \
+ (Tcl_DbCkalloc((x), __FILE__, __LINE__))
+# undef Tcl_GetStringFromObj
+# define Tcl_GetStringFromObj(x,y) \
+ (Tcl_DbGetStringFromObj((x), (y), __FILE__, __LINE__))
#endif /* !TCL_MEM_DEBUG */
#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ae214d2..0217343 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -520,7 +520,17 @@ UpdateStringOfDict(
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- flagPtr = (char *)Tcl_Alloc(numElems);
+ flagPtr = (char *)Tcl_AttemptAlloc(numElems);
+ if (!flagPtr) {
+ dictPtr->length = numElems;
+ allocError:
+ /* Allocation error. Just give up. */
+ if (dictPtr->bytes) {
+ Tcl_Free(dictPtr->bytes);
+ dictPtr->bytes = NULL;
+ }
+ return;
+ }
}
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
/*
@@ -530,11 +540,19 @@ UpdateStringOfDict(
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
- elem = TclGetStringFromObj(keyPtr, &length);
+ elem = TclAttemptGetStringFromObj(keyPtr, &length);
+ if (!elem) {
+ dictPtr->length = keyPtr->length;
+ goto allocError;
+ }
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
- elem = TclGetStringFromObj(valuePtr, &length);
+ elem = TclAttemptGetStringFromObj(valuePtr, &length);
+ if (!elem) {
+ dictPtr->length = valuePtr->length;
+ goto allocError;
+ }
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
}
bytesNeeded += numElems;
@@ -544,7 +562,10 @@ UpdateStringOfDict(
*/
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
- TclOOM(dst, bytesNeeded);
+ if (!dst) {
+ dictPtr->length = bytesNeeded;
+ goto allocError;
+ }
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
if (i) {
flagPtr[i] |= TCL_DONT_QUOTE_HASH;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 30f841d..d2a8b9b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4441,6 +4441,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
: (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
+#define TclAttemptGetString(objPtr) \
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_AttemptGetString(objPtr))
+
+#define TclAttemptGetStringFromObj(objPtr, lenPtr) \
+ ((objPtr)->bytes \
+ ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
+ : (Tcl_AttemptGetStringFromObj)((objPtr), (lenPtr)))
+
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
@@ -4812,6 +4820,20 @@ MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
+#define TclAttemptNewStringObj(objPtr, s, len) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ if (TclAttemptInitStringRep((objPtr), (s), (len))) { \
+ (objPtr)->typePtr = NULL; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } else { \
+ Tcl_DecrRefCount(objPtr); \
+ (objPtr) = NULL; \
+ } \
+ } while (0)
+
#else /* TCL_MEM_DEBUG */
#define TclNewIntObj(objPtr, w) \
(objPtr) = Tcl_NewWideIntObj(w)
@@ -4839,6 +4861,10 @@ MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;
#define TclNewStringObj(objPtr, s, len) \
(objPtr) = Tcl_NewStringObj((s), (len))
+
+#define TclAttemptNewStringObj(objPtr, s, len) \
+ (objPtr) = Tcl_AttemptNewStringObj((s), (len))
+
#endif /* TCL_MEM_DEBUG */
/*
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index aec2fbb..f6bd1ca 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -3537,14 +3537,25 @@ UpdateStringOfList(
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
- flagPtr = (char *)Tcl_Alloc(numElems);
+ flagPtr = (char *)Tcl_AttemptAlloc(numElems);
+ if (!flagPtr) {
+ listObj->length = numElems;
+ allocError:
+ /* Allocation error. Just give up. */
+ if (listObj->bytes) {
+ Tcl_Free(listObj->bytes);
+ listObj->bytes = NULL;
+ }
+ return;
+ }
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
- elem = TclGetStringFromObj(elemPtrs[i], &length);
+ elem = TclAttemptGetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded > SIZE_MAX - numElems) {
- Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX);
+ listObj->length = bytesNeeded;
+ goto allocError;
}
}
bytesNeeded += numElems - 1;
@@ -3553,13 +3564,20 @@ UpdateStringOfList(
* Pass 2: copy into string rep buffer.
*/
- start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
- TclOOM(dst, bytesNeeded);
+ start = dst = TclAttemptInitStringRep(listObj, NULL, bytesNeeded);
+ if (!start) {
+ listObj->length = bytesNeeded;
+ goto allocError;
+ }
for (i = 0; i < numElems; i++) {
if (i) {
flagPtr[i] |= TCL_DONT_QUOTE_HASH;
}
- elem = TclGetStringFromObj(elemPtrs[i], &length);
+ elem = TclAttemptGetStringFromObj(elemPtrs[i], &length);
+ if (!elem) {
+ listObj->length = elemPtrs[i]->length;
+ goto allocError;
+ }
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
diff --git a/generic/tclMain.c b/generic/tclMain.c
index e604a60..53c39e7 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -533,13 +533,20 @@ Tcl_MainEx(
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
- (void)Tcl_GetStringFromObj(resultPtr, &length);
- chan = Tcl_GetStdChannel(TCL_STDOUT);
- if ((length > 0) && chan) {
- if (Tcl_WriteObj(chan, resultPtr) < 0) {
- Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ (void)Tcl_AttemptGetStringFromObj(resultPtr, &length);
+ if (!resultPtr->bytes) {
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
+ Tcl_WriteChars(chan, "Memory allocation error\n", -1);
+ }
+ } else {
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if ((length > 0) && chan) {
+ if (Tcl_WriteObj(chan, resultPtr) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
+ Tcl_WriteChars(chan, "\n", 1);
}
- Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
@@ -813,12 +820,19 @@ StdinProc(
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
- (void)Tcl_GetStringFromObj(resultPtr, &length);
- if ((length > 0) && (chan != NULL)) {
- if (Tcl_WriteObj(chan, resultPtr) < 0) {
- Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ (void)Tcl_AttemptGetStringFromObj(resultPtr, &length);
+ if (!resultPtr->bytes) {
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan) {
+ Tcl_WriteChars(chan, "Memory allocation error\n", -1);
+ }
+ } else {
+ if ((length > 0) && (chan != NULL)) {
+ if (Tcl_WriteObj(chan, resultPtr) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
+ Tcl_WriteChars(chan, "\n", 1);
}
- Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index f9fc83f..87017d8 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1555,6 +1555,25 @@ TclObjBeingDeleted(
} \
}
+#define AttemptSetDuplicateObj(dupPtr, objPtr) \
+ { \
+ const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
+ const char *bytes = (objPtr)->bytes; \
+ if (bytes) { \
+ TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \
+ } else { \
+ (dupPtr)->bytes = NULL; \
+ } \
+ if (typePtr) { \
+ if (typePtr->dupIntRepProc) { \
+ typePtr->dupIntRepProc((objPtr), (dupPtr)); \
+ } else { \
+ (dupPtr)->internalRep = (objPtr)->internalRep; \
+ (dupPtr)->typePtr = typePtr; \
+ } \
+ } \
+ }
+
Tcl_Obj *
Tcl_DuplicateObj(
Tcl_Obj *objPtr) /* The object to duplicate. */
@@ -1566,6 +1585,21 @@ Tcl_DuplicateObj(
return dupPtr;
}
+Tcl_Obj *
+Tcl_AttemptDuplicateObj(
+ Tcl_Obj *objPtr) /* The object to duplicate. */
+{
+ Tcl_Obj *dupPtr;
+
+ TclNewObj(dupPtr);
+ AttemptSetDuplicateObj(dupPtr, objPtr);
+ if (!dupPtr->bytes) {
+ Tcl_DecrRefCount(dupPtr);
+ dupPtr = NULL;
+ }
+ return dupPtr;
+}
+
void
TclSetDuplicateObj(
Tcl_Obj *dupPtr,
@@ -1675,8 +1709,11 @@ Tcl_GetStringFromObj(
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
- if (objPtr->bytes == NULL
- || objPtr->bytes[objPtr->length] != '\0') {
+ if (objPtr->bytes == NULL) {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to allocate %" TCL_SIZE_MODIFIER "d bytes",
+ objPtr->typePtr->name, objPtr->length);
+ } else if (objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
@@ -1687,6 +1724,89 @@ Tcl_GetStringFromObj(
}
return objPtr->bytes;
}
+
+char *
+Tcl_DbGetStringFromObj(
+ Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
+ * be returned. */
+ Tcl_Size *lengthPtr, /* If non-NULL, the location where the string
+ * rep's byte array length should * be stored.
+ * If NULL, no length is stored. */
+ const char *file,
+ int line)
+{
+ if (objPtr->bytes == NULL) {
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
+ */
+
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s. %s:%d",
+ objPtr->typePtr->name, file, line);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL) {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to allocate %" TCL_SIZE_MODIFIER "d bytes. %s:%d",
+ objPtr->typePtr->name, objPtr->length, file, line);
+ } else if (objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep. %s:%d",
+ objPtr->typePtr->name, file, line);
+ }
+ }
+ if (lengthPtr != NULL) {
+ *lengthPtr = objPtr->length;
+ }
+ return objPtr->bytes;
+}
+
+char *
+Tcl_AttemptGetStringFromObj(
+ Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
+ * be returned. */
+ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string
+ * rep's byte array length should * be stored.
+ * If NULL, no length is stored. */
+{
+ if (objPtr->bytes == NULL) {
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
+ */
+
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes != NULL
+ && objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
+ }
+ if (lengthPtr != NULL) {
+ *lengthPtr = objPtr->bytes ? objPtr->length : -1;
+ }
+ return objPtr->bytes;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 93d0981..8ecc5cc 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -253,6 +253,24 @@ Tcl_NewStringObj(
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
+
+Tcl_Obj *
+Tcl_AttemptNewStringObj(
+ const char *bytes, /* Points to the first of the length bytes
+ * used to initialize the new object. */
+ Tcl_Size length) /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If -1,
+ * use bytes up to the first NUL byte. */
+{
+ Tcl_Obj *objPtr;
+
+ if (length < 0) {
+ length = (bytes? strlen(bytes) : 0);
+ }
+ TclAttemptNewStringObj(objPtr, bytes, length);
+ return objPtr;
+}
+
/*
*----------------------------------------------------------------------
@@ -901,6 +919,58 @@ Tcl_SetStringObj(
/*
*----------------------------------------------------------------------
*
+ * Tcl_AttemptSetStringObj --
+ *
+ * Modify an object to hold a string that is a copy of the bytes
+ * indicated by the byte pointer and length arguments.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string representation will be set to a copy of the
+ * "length" bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use bytes
+ * up to the first NUL byte; i.e., assume "bytes" points to a C-style
+ * NUL-terminated string. The object's old string and internal
+ * representations are freed and the object's type is set NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_AttemptSetStringObj(
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ const char *bytes, /* Points to the first of the length bytes
+ * used to initialize the object. */
+ Tcl_Size length) /* The number of bytes to copy from "bytes"
+ * when initializing the object. If -1,
+ * use bytes up to the first NUL byte.*/
+{
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
+ }
+
+ /*
+ * Set the type to NULL and free any internal rep for the old type.
+ */
+
+ TclFreeInternalRep(objPtr);
+
+ /*
+ * Free any old string rep, then set the string rep to a copy of the
+ * length bytes starting at "bytes".
+ */
+
+ TclInvalidateStringRep(objPtr);
+ if (length == TCL_INDEX_NONE) {
+ length = (bytes ? strlen(bytes) : 0);
+ }
+ return TclAttemptInitStringRep(objPtr, bytes, length);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_SetObjLength --
*
* Changes the length of the string representation of objPtr.
@@ -3723,7 +3793,7 @@ TclStringCmp(
case -1:
s1 = "";
s1len = 0;
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ s2 = TclAttemptGetStringFromObj(value2Ptr, &s2len);
break;
case 0:
match = -1;
@@ -3738,7 +3808,7 @@ TclStringCmp(
case -1:
s2 = "";
s2len = 0;
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ s1 = TclAttemptGetStringFromObj(value1Ptr, &s1len);
break;
case 0:
match = 1;
@@ -3749,8 +3819,11 @@ TclStringCmp(
goto matchdone;
}
} else {
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ s1 = TclAttemptGetStringFromObj(value1Ptr, &s1len);
+ s2 = TclAttemptGetStringFromObj(value2Ptr, &s2len);
+ }
+ if (!s1 || !s2) {
+ return INT_MIN;
}
if (!nocase && checkEq && reqlength < 0) {
/*
@@ -4504,7 +4577,7 @@ DupStringInternalRep(
static int
SetStringFromAny(
- TCL_UNUSED(Tcl_Interp *),
+ Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The object to convert. */
{
if (!TclHasInternalRep(objPtr, &tclStringType)) {
@@ -4514,7 +4587,11 @@ SetStringFromAny(
* Convert whatever we have into an untyped value. Just A String.
*/
- (void) TclGetString(objPtr);
+ (void)TclAttemptGetString(objPtr);
+ if (!objPtr->bytes) {
+ Tcl_AppendResult(interp, "allocation error", (char *)NULL);
+ return TCL_ERROR;
+ }
TclFreeInternalRep(objPtr);
/*
@@ -4615,7 +4692,11 @@ ExtendStringRepWithUnicode(
size += TclUtfCount(unicode[i]);
}
if (size < 0) {
- Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX);
+ if (objPtr->bytes) {
+ Tcl_Free(objPtr->bytes);
+ objPtr->bytes = NULL;
+ }
+ return TCL_ERROR;
}
/*
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8839e0b..6a742d5 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -829,7 +829,7 @@ const TclStubs tclStubs = {
Tcl_DbDecrRefCount, /* 19 */
Tcl_DbIncrRefCount, /* 20 */
Tcl_DbIsShared, /* 21 */
- 0, /* 22 */
+ Tcl_DbGetStringFromObj, /* 22 */
Tcl_DbNewByteArrayObj, /* 23 */
Tcl_DbNewDoubleObj, /* 24 */
Tcl_DbNewListObj, /* 25 */
@@ -864,7 +864,7 @@ const TclStubs tclStubs = {
0, /* 54 */
Tcl_NewObj, /* 55 */
Tcl_NewStringObj, /* 56 */
- 0, /* 57 */
+ Tcl_AttemptNewStringObj, /* 57 */
Tcl_SetByteArrayLength, /* 58 */
Tcl_SetByteArrayObj, /* 59 */
Tcl_SetDoubleObj, /* 60 */
@@ -1147,9 +1147,9 @@ const TclStubs tclStubs = {
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
- 0, /* 340 */
- 0, /* 341 */
- 0, /* 342 */
+ Tcl_AttemptGetStringFromObj, /* 340 */
+ Tcl_AttemptSetStringObj, /* 341 */
+ Tcl_AttemptDuplicateObj, /* 342 */
Tcl_AlertNotifier, /* 343 */
Tcl_ServiceModeHook, /* 344 */
Tcl_UniCharIsAlnum, /* 345 */