summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h6
-rw-r--r--generic/tclAssembly.c6
-rw-r--r--generic/tclCmdAH.c7
-rw-r--r--generic/tclCompCmdsGR.c2
-rw-r--r--generic/tclCompCmdsSZ.c6
-rw-r--r--generic/tclCompExpr.c18
-rw-r--r--generic/tclCompile.c22
-rw-r--r--generic/tclCompile.h30
-rw-r--r--generic/tclEnsemble.c13
-rw-r--r--generic/tclExecute.c32
-rw-r--r--generic/tclFCmd.c10
-rw-r--r--generic/tclHash.c12
-rw-r--r--generic/tclIO.c159
-rw-r--r--generic/tclIO.h6
-rw-r--r--generic/tclIndexObj.c34
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h22
-rw-r--r--generic/tclIntDecls.h4
-rw-r--r--generic/tclInterp.c11
-rw-r--r--generic/tclLiteral.c49
-rw-r--r--generic/tclNamesp.c11
-rw-r--r--generic/tclObj.c162
-rw-r--r--generic/tclProc.c24
-rw-r--r--generic/tclTest.c96
-rw-r--r--generic/tclTestObj.c18
-rw-r--r--generic/tclUtf.c68
-rw-r--r--generic/tclVar.c458
-rw-r--r--generic/tclZlib.c48
28 files changed, 562 insertions, 774 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 6061ea8..ded8d0b 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1157,11 +1157,15 @@ typedef struct Tcl_DString {
* Forward declarations of Tcl_HashTable and related types.
*/
+#ifndef TCL_HASH_TYPE
+# define TCL_HASH_TYPE unsigned
+#endif
+
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
-typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
+typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr);
typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr,
void *keyPtr);
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7a5ffcc..06f277f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1300,7 +1300,7 @@ AssembleOneLine(
goto cleanup;
}
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
@@ -1449,7 +1449,7 @@ AssembleOneLine(
goto cleanup;
} else {
operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
@@ -3541,7 +3541,7 @@ StackCheckExit(
* Emit a 'push' of the empty literal.
*/
- litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+ litIndex = TclRegisterLiteral(envPtr, "", 0, 0);
/*
* Assumes that 'push' is at slot 0 in TalInstructionTable.
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 13d3df5..4c299f8 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1596,14 +1596,19 @@ FileAttrIsOwnedCmd(
int objc,
Tcl_Obj *const objv[])
{
+#ifdef __CYGWIN__
+#define geteuid() (short)(geteuid)()
+#endif
+#if !defined(_WIN32)
Tcl_StatBuf buf;
+#endif
int value = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
-#if defined(_WIN32) || defined(__CYGWIN__)
+#if defined(_WIN32)
value = TclWinFileOwned(objv[1]);
#else
if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) {
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 593a8af..ff5495c 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -2761,7 +2761,7 @@ TclCompileSyntaxError(
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 2503089..10b3cc8 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1456,8 +1456,8 @@ TclSubstCompile(
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
- literal = TclRegisterNewLiteral(envPtr,
- tokenPtr->start, tokenPtr->size);
+ literal = TclRegisterLiteral(envPtr,
+ tokenPtr->start, tokenPtr->size, 0);
TclEmitPush(literal, envPtr);
TclAdvanceLines(&bline, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
@@ -1466,7 +1466,7 @@ TclSubstCompile(
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
- literal = TclRegisterNewLiteral(envPtr, buf, length);
+ literal = TclRegisterLiteral(envPtr, buf, length, 0);
TclEmitPush(literal, envPtr);
count++;
continue;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 654666a..83bb883 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2267,9 +2267,9 @@ CompileExprTree(
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
- TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
+ TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
- Tcl_DStringLength(&cmdName)), envPtr);
+ Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
/*
@@ -2376,8 +2376,8 @@ CompileExprTree(
pc1 = CurrentOffset(envPtr);
TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
: INST_JUMP_TRUE1, 0, envPtr);
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr);
pc2 = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
@@ -2386,8 +2386,8 @@ CompileExprTree(
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
pc2 += 3;
}
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
envPtr->codeStart + pc2 + 1);
convert = 0;
@@ -2421,7 +2421,7 @@ CompileExprTree(
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
- int index = TclRegisterNewLiteral(envPtr, bytes, length);
+ int index = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
@@ -2479,8 +2479,8 @@ CompileExprTree(
if (objPtr->bytes) {
Tcl_Obj *tableValue;
- index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
- objPtr->length);
+ index = TclRegisterLiteral(envPtr, objPtr->bytes,
+ objPtr->length, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0024f1e..c588731 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1792,9 +1792,17 @@ CompileCmdLiteral(
CompileEnv *envPtr)
{
int numBytes;
- const char *bytes = TclGetStringFromObj(cmdObj, &numBytes);
- int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
- Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ const char *bytes;
+ Command *cmdPtr;
+ int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags |= LITERAL_UNSHARED;
+ }
+
+ bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
@@ -1829,8 +1837,8 @@ TclCompileInvocation(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1879,8 +1887,8 @@ CompileExpanded(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index f99c07c..89cdc59 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1095,7 +1095,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
-MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
int length, unsigned int hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
@@ -1210,29 +1210,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
-
-/*
- * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
- * cast away constness, and it is cleanest to do that here, all in one place.
- *
- * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes,
- * int length);
- */
-
-#define TclRegisterNewLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)
-
-/*
- * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it
- * is safe to cast away constness, and it is cleanest to do that here, all in
- * one place.
- *
- * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
- * int length);
- */
-
-#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
+#define LITERAL_UNSHARED 0x04
/*
* Macro used to manually adjust the stack requirements; used in cases where
@@ -1549,9 +1527,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
*/
#define PushLiteral(envPtr, string, length) \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+ TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr))
#define PushStringLiteral(envPtr, string) \
- PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
+ PushLiteral(envPtr, string, (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 2766769..43813f1 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3306,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit;
+ int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
@@ -3326,8 +3326,8 @@ CompileToInvokedCommand(
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- int literal = TclRegisterNewLiteral(envPtr,
- tokPtr[1].start, tokPtr[1].size);
+ int literal = TclRegisterLiteral(envPtr,
+ tokPtr[1].start, tokPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
@@ -3348,8 +3348,11 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = TclGetStringFromObj(objPtr, &length);
- cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags |= LITERAL_UNSHARED;
+ }
+ cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f74c468..556ec55 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1554,7 +1554,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -2071,6 +2071,13 @@ TclNRExecuteByteCode(
#endif
/*
+ * Test namespace-50.9 demonstrates the need for this call.
+ * Use a --enable-symbols=mem bug to see.
+ */
+
+ TclResetRewriteEnsemble(interp, 1);
+
+ /*
* Push the callback for bytecode execution
*/
@@ -3166,7 +3173,7 @@ TEBCresume(
Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
Tcl_ListObjAppendElement(NULL, copyPtr, objPtr);
- Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - opnd, objv + opnd);
Tcl_DecrRefCount(objPtr);
objPtr = copyPtr;
@@ -5276,23 +5283,10 @@ TEBCresume(
toIdx = objc-1;
}
if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) {
- /*
- * BEWARE! This is looking inside the implementation of the
- * list type.
- */
-
- List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1;
-
- if (listPtr->refCount == 1) {
- for (index=toIdx+1; index<objc ; index++) {
- TclDecrRefCount(objv[index]);
- }
- listPtr->elemCount = toIdx+1;
- listPtr->canonicalFlag = 1;
- TclInvalidateStringRep(valuePtr);
- TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
- NEXT_INST_F(9, 0, 0);
- }
+ Tcl_ListObjReplace(interp, valuePtr,
+ toIdx + 1, LIST_MAX, 0, NULL);
+ TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+ NEXT_INST_F(9, 0, 0);
}
objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
} else {
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index bb814ea..80898fc 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -1079,12 +1079,9 @@ TclFileAttrsCmd(
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[0]);
- }
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
@@ -1107,12 +1104,9 @@ TclFileAttrsCmd(
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[i]);
- }
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 3ea9dd9..ac9d40e 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -43,7 +43,7 @@
static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
+static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the one word hash key methods. Not actually declared because
@@ -65,7 +65,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr);
static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr,
void *keyPtr);
static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
+static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Function prototypes for static functions in this file:
@@ -774,7 +774,7 @@ CompareArrayKeys(
*----------------------------------------------------------------------
*/
-static unsigned int
+static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -787,7 +787,7 @@ HashArrayKey(
count--, array++) {
result += *array;
}
- return result;
+ return (TCL_HASH_TYPE) result;
}
/*
@@ -870,7 +870,7 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
-static unsigned
+static TCL_HASH_TYPE
HashStringKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -916,7 +916,7 @@ HashStringKey(
result += (result << 3) + UCHAR(c);
}
}
- return result;
+ return (TCL_HASH_TYPE) result;
}
/*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index f93d00d..80f6fa4 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -313,15 +313,20 @@ static int WillRead(Channel *chanPtr);
&& (strncmp(optionName, (nameString), len) == 0))
/*
- * The ChannelObjType type. We actually store the ChannelState structure
- * as that lives longest and we want to return the bottomChanPtr when
- * requested (consistent with Tcl_GetChannel). The setFromAny and
- * updateString can be NULL as they should not be called.
+ * The ChannelObjType type. Used to store the result of looking up
+ * a channel name in the context of an interp. Saves the lookup
+ * result and values needed to check its continued validity.
*/
+typedef struct ResolvedChanName {
+ ChannelState *statePtr; /* The saved lookup result */
+ Tcl_Interp *interp; /* The interp in which the lookup was done. */
+ int epoch; /* The epoch of the channel when the lookup
+ * was done. Use to verify validity. */
+ int refCount; /* Share this struct among many Tcl_Obj. */
+} ResolvedChanName;
+
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
-static int SetChannelFromAny(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
static void FreeChannelIntRep(Tcl_Obj *objPtr);
static const Tcl_ObjType chanObjType = {
@@ -329,18 +334,9 @@ static const Tcl_ObjType chanObjType = {
FreeChannelIntRep, /* freeIntRepProc */
DupChannelIntRep, /* dupIntRepProc */
NULL, /* updateStringProc */
- NULL /* setFromAnyProc SetChannelFromAny */
+ NULL /* setFromAnyProc */
};
-#define GET_CHANNELSTATE(objPtr) \
- ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1)
-#define SET_CHANNELSTATE(objPtr, storePtr) \
- ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
-#define GET_CHANNELINTERP(objPtr) \
- ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
-#define SET_CHANNELINTERP(objPtr, storePtr) \
- ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr))
-
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -1021,7 +1017,7 @@ DeleteChannelTable(
*/
Tcl_DeleteHashEntry(hPtr);
- SetFlag(statePtr, CHANNEL_TAINTED);
+ statePtr->epoch++;
if (statePtr->refCount-- <= 1) {
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
@@ -1365,7 +1361,7 @@ DetachChannel(
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
- SetFlag(statePtr, CHANNEL_TAINTED);
+ statePtr->epoch++;
/*
* Remove channel handlers that refer to this interpreter, so that
@@ -1498,12 +1494,57 @@ TclGetChannelFromObj(
int flags)
{
ChannelState *statePtr;
+ ResolvedChanName *resPtr = NULL;
+ Tcl_Channel chan;
+
+ if (interp == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (objPtr->typePtr == &chanObjType) {
+ /*
+ * Confirm validity of saved lookup results.
+ */
+
+ resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1;
+ statePtr = resPtr->statePtr;
+ if ((resPtr->interp == interp) /* Same interp context */
+ /* No epoch change in channel since lookup */
+ && (resPtr->epoch == statePtr->epoch)) {
+
+ /* Have a valid saved lookup. Jump to end to return it. */
+ goto valid;
+ }
+ }
+
+ chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
- if (SetChannelFromAny(interp, objPtr) != TCL_OK) {
+ if (chan == NULL) {
+ if (resPtr) {
+ FreeChannelIntRep(objPtr);
+ }
return TCL_ERROR;
}
- statePtr = GET_CHANNELSTATE(objPtr);
+ if (resPtr && resPtr->refCount == 1) {
+ /* Re-use the ResolvedCmdName struct */
+ Tcl_Release((ClientData) resPtr->statePtr);
+
+ } else {
+ TclFreeIntRep(objPtr);
+
+ resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
+ resPtr->refCount = 1;
+ objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr;
+ objPtr->typePtr = &chanObjType;
+ }
+ statePtr = ((Channel *)chan)->state;
+ resPtr->statePtr = statePtr;
+ Tcl_Preserve((ClientData) statePtr);
+ resPtr->interp = interp;
+ resPtr->epoch = statePtr->epoch;
+
+ valid:
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
@@ -1676,6 +1717,8 @@ Tcl_CreateChannel(
statePtr->chanMsg = NULL;
statePtr->unreportedMsg = NULL;
+ statePtr->epoch = 0;
+
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels in
@@ -11121,78 +11164,16 @@ DupChannelIntRep(
register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- ChannelState *statePtr = GET_CHANNELSTATE(srcPtr);
+ ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- SET_CHANNELSTATE(copyPtr, statePtr);
- SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr));
- Tcl_Preserve(statePtr);
+ resPtr->refCount++;
+ copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->typePtr = srcPtr->typePtr;
}
/*
*----------------------------------------------------------------------
*
- * SetChannelFromAny --
- *
- * Create an internal representation of type "Channel" for an object.
- *
- * Results:
- * This operation always succeeds and returns TCL_OK.
- *
- * Side effects:
- * Any old internal reputation for objPtr is freed and the internal
- * representation is set to "Channel".
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetChannelFromAny(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
-{
- ChannelState *statePtr;
-
- if (interp == NULL) {
- return TCL_ERROR;
- }
- if (objPtr->typePtr == &chanObjType) {
- /*
- * TODO: TAINT Flag and dup'd channel values?
- * The channel is valid until any call to DetachChannel occurs.
- * Ensure consistency checks are done.
- */
-
- statePtr = GET_CHANNELSTATE(objPtr);
- if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) {
- ResetFlag(statePtr, CHANNEL_TAINTED);
- Tcl_Release(statePtr);
- objPtr->typePtr = NULL;
- } else if (interp != GET_CHANNELINTERP(objPtr)) {
- Tcl_Release(statePtr);
- objPtr->typePtr = NULL;
- }
- }
- if (objPtr->typePtr != &chanObjType) {
- Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
-
- if (chan == NULL) {
- return TCL_ERROR;
- }
-
- TclFreeIntRep(objPtr);
- statePtr = ((Channel *) chan)->state;
- Tcl_Preserve(statePtr);
- SET_CHANNELSTATE(objPtr, statePtr);
- SET_CHANNELINTERP(objPtr, interp);
- objPtr->typePtr = &chanObjType;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* FreeChannelIntRep --
*
* Release statePtr storage.
@@ -11210,8 +11191,14 @@ static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- Tcl_Release(GET_CHANNELSTATE(objPtr));
+ ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+
objPtr->typePtr = NULL;
+ if (--resPtr->refCount) {
+ return;
+ }
+ Tcl_Release(resPtr->statePtr);
+ ckfree(resPtr);
}
#if 0
diff --git a/generic/tclIO.h b/generic/tclIO.h
index b799375..ffbfa31 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -214,6 +214,8 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
+ int epoch; /* Used to test validity of stored channelname
+ * lookup results. */
} ChannelState;
/*
@@ -275,10 +277,6 @@ typedef struct ChannelState {
* usable, but it may not be closed
* again from within the close
* handler. */
-#define CHANNEL_TAINTED (1<<20) /* Channel stack structure has changed.
- * Used by Channel Tcl_Obj type to
- * determine if we have to revalidate
- * the channel. */
#define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed.
* No further Tcl-level write IO on
* the channel is allowed. */
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 2281d22..6a3e4e3 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -114,14 +114,13 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
-
/*
* See if there is a valid cached result from a previous lookup (doing the
* check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
+ if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
@@ -211,13 +210,8 @@ GetIndexFromObjList(
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
- sizeof(char *), msg, flags, indexPtr);
-
- /*
- * The internal rep must be cleared since tablePtr will go away.
- */
+ sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr);
- TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
@@ -279,7 +273,7 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr->typePtr == &indexType) {
+ if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
@@ -340,17 +334,19 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- } else {
- TclFreeIntRep(objPtr);
- indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
+ if (!(flags & INDEX_TEMP_TABLE)) {
+ if (objPtr->typePtr == &indexType) {
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ } else {
+ TclFreeIntRep(objPtr);
+ indexRep = ckalloc(sizeof(IndexRep));
+ objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
+ objPtr->typePtr = &indexType;
+ }
+ indexRep->tablePtr = (void *) tablePtr;
+ indexRep->offset = offset;
+ indexRep->index = index;
}
- indexRep->tablePtr = (void *) tablePtr;
- indexRep->offset = offset;
- indexRep->index = index;
*indexPtr = index;
return TCL_OK;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 4e7e422..c00dff1 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1009,7 +1009,7 @@ declare 250 {
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
- char *bytes, int length, int flags)
+ const char *bytes, int length, int flags)
}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1d01116..cee6b09 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1690,11 +1690,13 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x1
-#define CMD_TRACE_ACTIVE 0x2
-#define CMD_HAS_EXEC_TRACES 0x4
-#define CMD_COMPILES_EXPANDED 0x8
+#define CMD_IS_DELETED 0x01
+#define CMD_TRACE_ACTIVE 0x02
+#define CMD_HAS_EXEC_TRACES 0x04
+#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
+#define CMD_VIA_RESOLVER 0x20
+
/*
*----------------------------------------------------------------
@@ -2548,6 +2550,15 @@ typedef struct TclFileAttrProcs {
} TclFileAttrProcs;
/*
+ * Private flag value which controls Tcl_GetIndexFromObj*() routines
+ * to instruct them not to cache lookups because the table will not
+ * live long enough to make it worthwhile. Must not clash with public
+ * flag value TCL_EXACT.
+ */
+
+#define INDEX_TEMP_TABLE 2
+
+/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
*/
@@ -2698,7 +2709,6 @@ MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
-MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
#ifndef TCL_WIDE_INT_IS_LONG
MODULE_SCOPE const Tcl_ObjType tclWideIntType;
@@ -3982,7 +3992,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
-MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
+MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index f95f999..dfa5727 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -615,7 +615,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
/* 251 */
-EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
+EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes,
int length, int flags);
typedef struct TclIntStubs {
@@ -873,7 +873,7 @@ typedef struct TclIntStubs {
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
- int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
+ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index a2de658..1bfe76a 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -660,14 +660,9 @@ NRInterpCmd(
if (masterInterp == NULL) {
return TCL_ERROR;
}
- if (TclGetString(objv[5])[0] == '\0') {
- if (objc == 6) {
- return AliasDelete(interp, slaveInterp, objv[3]);
- }
- } else {
- return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
- objv[5], objc - 6, objv + 6);
- }
+
+ return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
+ objv[5], objc - 6, objv + 6);
}
goto aliasArgs;
}
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index e0425cf..7acc9ad 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -174,7 +174,7 @@ TclDeleteLiteralTable(
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
- char *bytes, /* The start of the string. Note that this is
+ const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
int length, /* Number of bytes in the string. */
unsigned hash, /* The string's hash. If -1, it will be
@@ -214,7 +214,7 @@ TclCreateLiteral(
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
globalPtr->refCount++;
@@ -222,26 +222,40 @@ TclCreateLiteral(
}
}
if (!newPtr) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
}
/*
- * The literal is new to the interpreter. Add it to the global literal
- * table.
+ * The literal is new to the interpreter.
*/
TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- if (flags & LITERAL_ON_HEAP) {
- objPtr->bytes = bytes;
+ if ((flags & LITERAL_ON_HEAP)) {
+ objPtr->bytes = (char *) bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+ /* Should the new literal be shared globally? */
+
+ if ((flags & LITERAL_UNSHARED)) {
+ /*
+ * No, do *not* add it the global literal table
+ * Make clear, that no global value is returned
+ */
+ if (globalPtrPtr != NULL) {
+ *globalPtrPtr = NULL;
+ }
+ return objPtr;
+ }
+
+ /*
+ * Yes, add it to the global literal table.
+ */
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -251,6 +265,7 @@ TclCreateLiteral(
globalPtr = ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr);
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
@@ -360,7 +375,7 @@ int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
- register char *bytes, /* Points to string for which to find or
+ register const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length, /* Number of bytes in the string. If < 0, the
@@ -398,7 +413,7 @@ TclRegisterLiteral(
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
@@ -417,7 +432,7 @@ TclRegisterLiteral(
* the namespace as the interp's global NS.
*/
- if (flags & LITERAL_CMD_NAME) {
+ if ((flags & LITERAL_CMD_NAME)) {
if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
nsPtr = iPtr->globalNsPtr;
} else {
@@ -431,12 +446,13 @@ TclRegisterLiteral(
* Is it in the interpreter's global literal table? If not, create it.
*/
+ globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount < 1) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -1025,7 +1041,7 @@ TclInvalidateCmdLiteral(
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
+ Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL) {
@@ -1152,13 +1168,6 @@ TclVerifyLocalLiteralTable(
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
- if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
- localPtr->objPtr) == NULL) {
- bytes = TclGetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" is not global",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes);
- }
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5930859..7f6ecf5 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2566,7 +2566,9 @@ Tcl_FindCommand(
}
if (result == TCL_OK) {
+ ((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
+
} else if (result != TCL_CONTINUE) {
return NULL;
}
@@ -2658,6 +2660,7 @@ Tcl_FindCommand(
}
if (cmdPtr != NULL) {
+ cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
@@ -2883,9 +2886,9 @@ GetNamespaceFromObj(
resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
- if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
- (!refNsPtr || ((interp == refNsPtr->interp) &&
- (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
+ if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
+ && (!refNsPtr || (refNsPtr ==
+ (Namespace *) TclGetCurrentNamespace(interp)))) {
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
@@ -4779,7 +4782,7 @@ SetNsNameFromAny(
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
- resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 1;
TclFreeIntRep(objPtr);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 776b034..d3f59ec 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -402,7 +402,6 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
- Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
@@ -4048,7 +4047,7 @@ TclFreeObjEntry(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclHashObjKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
@@ -4098,7 +4097,7 @@ TclHashObjKey(
result += (result << 3) + UCHAR(*++string);
}
}
- return result;
+ return (TCL_HASH_TYPE) result;
}
/*
@@ -4152,11 +4151,10 @@ Tcl_GetCommandFromObj(
*/
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ if (objPtr->typePtr == &tclCmdNameType) {
register Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
- && !(cmdPtr->flags & CMD_IS_DELETED)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
register Namespace *refNsPtr = (Namespace *)
@@ -4204,54 +4202,78 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
-void
-TclSetCmdNameObj(
- Tcl_Interp *interp, /* Points to interpreter containing command
- * that should be cached in objPtr. */
- register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
- * CmdName object. */
- Command *cmdPtr) /* Points to Command structure that the
- * CmdName object should refer to. */
+static void
+SetCmdNameObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Command *cmdPtr,
+ ResolvedCmdName *resPtr)
{
Interp *iPtr = (Interp *) interp;
- register ResolvedCmdName *resPtr;
- register Namespace *currNsPtr;
- const char *name;
+ ResolvedCmdName *fillPtr;
+ const char *name = TclGetString(objPtr);
- if (objPtr->typePtr == &tclCmdNameType) {
- return;
+ if (resPtr) {
+ fillPtr = resPtr;
+ } else {
+ fillPtr = ckalloc(sizeof(ResolvedCmdName));
+ fillPtr->refCount = 1;
}
+ fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
- resPtr = ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
+ fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
- name = TclGetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
+ /* NOTE: relying on NULL termination here. */
+ if ((name[0] == ':') && (name[1] == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * Fully qualified names always resolve to same thing. No need
+ * to record resolution context information.
*/
- resPtr->refNsPtr = NULL;
+ fillPtr->refNsPtr = NULL;
+ fillPtr->refNsId = 0; /* Will not be read */
+ fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
- * Get the current namespace.
+ * Record current state of current namespace as the resolution
+ * context of this command name lookup.
*/
+ Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
+
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ if (resPtr == NULL) {
+ TclFreeIntRep(objPtr);
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
+}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+void
+TclSetCmdNameObj(
+ Tcl_Interp *interp, /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ register Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
+ * CmdName object. */
+ Command *cmdPtr) /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ register ResolvedCmdName *resPtr;
+
+ if (objPtr->typePtr == &tclCmdNameType) {
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
+ }
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4282,7 +4304,6 @@ FreeCmdNameInternalRep(
{
register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
@@ -4300,7 +4321,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4333,9 +4353,7 @@ DupCmdNameInternalRep(
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- if (resPtr != NULL) {
resPtr->refCount++;
- }
copyPtr->typePtr = &tclCmdNameType;
}
@@ -4365,10 +4383,8 @@ SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
- Interp *iPtr = (Interp *) interp;
const char *name;
register Command *cmdPtr;
- Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
if (interp == NULL) {
@@ -4388,59 +4404,31 @@ SetCmdNameFromAny(
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
- * Free the old internalRep before setting the new one. Do this after
- * getting the string rep to allow the conversion code (in particular,
- * Tcl_GetStringFromObj) to use that old internalRep.
+ * Stop shimmering and caching nothing when we found nothing. Just
+ * report the failure to find the command as an error.
*/
- if (cmdPtr) {
- cmdPtr->refCount++;
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType)
- && resPtr && (resPtr->refCount == 1)) {
- /*
- * Reuse the old ResolvedCmdName struct instead of freeing it
- */
-
- Command *oldCmdPtr = resPtr->cmdPtr;
-
- if (--oldCmdPtr->refCount == 0) {
- TclCleanupCommandMacro(oldCmdPtr);
- }
- } else {
- TclFreeIntRep(objPtr);
- resPtr = ckalloc(sizeof(ResolvedCmdName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- }
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- if ((*name++ == ':') && (*name == ':')) {
- /*
- * The name is fully qualified: set the referring namespace to
- * NULL.
- */
+ if (cmdPtr == NULL) {
+ return TCL_ERROR;
+ }
- resPtr->refNsPtr = NULL;
- } else {
- /*
- * Get the current namespace.
- */
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
+ /*
+ * Re-use existing ResolvedCmdName struct when possible.
+ * Cleanup the old fields that need it.
+ */
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ Command *oldCmdPtr = resPtr->cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ if (--oldCmdPtr->refCount == 0) {
+ TclCleanupCommandMacro(oldCmdPtr);
}
} else {
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+ resPtr = NULL;
}
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
return TCL_OK;
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 81d3b25..bed520a 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2654,30 +2654,6 @@ TclNRApplyObjCmd(
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
-#define JOE_EXTENSION 0
-/*
- * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
- * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
- * the code. (MS)
- */
-
-#if JOE_EXTENSION
- else {
- /*
- * Joe English's suggestion to allow cmdNames to function as lambdas.
- */
-
- Tcl_Obj *elemPtr;
- int numElem;
-
- if ((lambdaPtr->typePtr == &tclCmdNameType) ||
- (TclListObjGetElements(interp, lambdaPtr, &numElem,
- &elemPtr) == TCL_OK && numElem == 1)) {
- return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
- }
- }
-#endif
-
if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
result = SetLambdaFromAny(interp, lambdaPtr);
if (result != TCL_OK) {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d3da641..47d85e1 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7326,24 +7326,83 @@ InterpCmdResolver(
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
- Namespace *ns2NsPtr = (Namespace *)
- Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+ Namespace *callerNsPtr = varFramePtr->nsPtr;
+ Tcl_Command resolvedCmdPtr = NULL;
- if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
- || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
- const char *callingCmdName =
+ /*
+ * Just do something special on a cmd literal "z" in two cases:
+ * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
+ * B) the caller's namespace is "ctx1" or "ctx2"
+ */
+ if ( (name[0] == 'z') && (name[1] == '\0') ) {
+ Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr != NULL
+ && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
+ || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
+ )
+ ) {
+ /*
+ * Case A)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the caller proc, which has to be
+ * named "x".
+ *
+ * - To determine the name of the caller proc, the proc is taken
+ * from the topmost stack frame.
+ *
+ * - Note that the context is NOT provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y", which is taken from the
+ * the global namespace (for simplicity).
+ */
+
+ const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
- if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
- && (name[0] == 'z') && (name[1] == '\0')) {
- Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
- TCL_GLOBAL_ONLY);
+ if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ }
+ } else if (callerNsPtr != NULL) {
+ /*
+ * Case B)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the parent namespace, which has
+ * to be named "ctx1" or "ctx2".
+ *
+ * - To determine the name of the parent namesace, it is taken
+ * from the 2nd highest stack frame.
+ *
+ * - Note that the context can be provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y" or "Y" depending on the
+ * context. The resolved procs are taken from the the global
+ * namespace (for simplicity).
+ */
+
+ CallFrame *parentFramePtr = varFramePtr->callerPtr;
+ char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
- if (sourceCmdPtr != NULL) {
- *rPtr = sourceCmdPtr;
- return TCL_OK;
+ if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
+
+ } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
+ /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
+
+ if (resolvedCmdPtr != NULL) {
+ *rPtr = resolvedCmdPtr;
+ return TCL_OK;
+ }
}
return TCL_CONTINUE;
}
@@ -7476,9 +7535,16 @@ TestInterpResolverCmd(
int idx;
#define RESOLVER_KEY "testInterpResolver"
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "up|down");
- return TCL_ERROR;
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
+ if (interp == NULL) {
+ Tcl_AppendResult(interp, "provided interpreter not found", NULL);
+ return TCL_ERROR;
+ }
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index a637498..6053ae3 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -577,23 +577,9 @@ TestindexobjCmd(
}
argv[objc-4] = NULL;
- /*
- * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
- * that its address is different for each index object. If we accidently
- * allocate a table at the same address as that cached in the index
- * object, clear out the object's cached state.
- */
-
- if (objv[3]->typePtr != NULL
- && !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
- if (indexRep->tablePtr == (void *) argv) {
- TclFreeIntRep(objv[3]);
- }
- }
-
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
- argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
+ argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
+ &index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 6c4cb7f..b33bf6a 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -73,16 +73,7 @@ static const unsigned char totalBytes[256] = {
#else
1,1,1,1,1,1,1,1,
#endif
-#if TCL_UTF_MAX > 4
- 5,5,5,5,
-#else
- 1,1,1,1,
-#endif
-#if TCL_UTF_MAX > 5
- 6,6,6,6
-#else
- 1,1,1,1
-#endif
+ 1,1,1,1,1,1,1,1
};
/*
@@ -105,14 +96,14 @@ int
TclUtfCount(
int ch) /* The Tcl_UniChar whose size is returned. */
{
- if ((ch > 0) && (ch < UNICODE_SELF)) {
+ if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
return 1;
}
if (ch <= 0x7FF) {
return 2;
}
#if TCL_UTF_MAX > 3
- if ((ch > 0xFFFF) && (ch <= 0x10FFFF)) {
+ if (((unsigned)(ch - 0x10000) <= 0xfffff)) {
return 4;
}
#endif
@@ -146,7 +137,7 @@ Tcl_UniCharToUtf(
* large enough to hold the UTF-8 character
* (at most TCL_UTF_MAX bytes). */
{
- if ((ch > 0) && (ch < UNICODE_SELF)) {
+ if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
return 1;
}
@@ -174,11 +165,7 @@ Tcl_UniCharToUtf(
}
}
#endif
- three:
- buf[2] = (char) ((ch | 0x80) & 0xBF);
- buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
- buf[0] = (char) ((ch >> 12) | 0xE0);
- return 3;
+ goto three;
}
#if TCL_UTF_MAX > 3
@@ -193,7 +180,11 @@ Tcl_UniCharToUtf(
}
ch = 0xFFFD;
- goto three;
+three:
+ buf[2] = (char) ((ch | 0x80) & 0xBF);
+ buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ buf[0] = (char) ((ch >> 12) | 0xE0);
+ return 3;
}
/*
@@ -308,9 +299,6 @@ Tcl_UtfToUniChar(
* A two-byte-character lead-byte not followed by trail-byte
* represents itself.
*/
-
- *chPtr = (Tcl_UniChar) byte;
- return 1;
} else if (byte < 0xF0) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
@@ -326,31 +314,23 @@ Tcl_UtfToUniChar(
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
-
- *chPtr = (Tcl_UniChar) byte;
- return 1;
}
#if TCL_UTF_MAX > 3
- {
- int ch, total, trail;
-
- total = totalBytes[byte];
- trail = total - 1;
- if (trail > 0) {
- ch = byte & (0x3F >> trail);
- do {
- src++;
- if ((*src & 0xC0) != 0x80) {
- *chPtr = byte;
- return 1;
- }
- ch <<= 6;
- ch |= (*src & 0x3F);
- trail--;
- } while (trail > 0);
- *chPtr = ch;
- return total;
+ else if (byte < 0xF8) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
+ /*
+ * Four-byte-character lead byte followed by three trail bytes.
+ */
+
+ *chPtr = (Tcl_UniChar) (((byte & 0x0E) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
+ return 4;
}
+
+ /*
+ * A three-byte-character lead-byte not followed by two trail-bytes
+ * represents itself.
+ */
}
#endif
diff --git a/generic/tclVar.c b/generic/tclVar.c
index a9bedd7..48e09f6 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -149,6 +149,7 @@ static const char *isArrayElement =
*/
typedef struct ArraySearch {
+ Tcl_Obj *name; /* Name of this search */
int id; /* Integer id used to distinguish among
* multiple concurrent searches for the same
* array. */
@@ -188,8 +189,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags, int index);
-static int SetArraySearchObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
+static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj);
/*
* Functions defined in this file that may be exported in the future for use
@@ -214,10 +214,6 @@ static Tcl_DupInternalRepProc DupParsedVarName;
* or NULL if it is this same obj
* twoPtrValue.ptr2: index into locals table
*
- * nsVarName - INTERNALREP DEFINITION:
- * twoPtrValue.ptr1: pointer to the namespace containing the reference
- * twoPtrValue.ptr2: pointer to the corresponding Var
- *
* parsedVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a
* scalar variable
@@ -235,22 +231,6 @@ static const Tcl_ObjType tclParsedVarNameType = {
FreeParsedVarName, DupParsedVarName, NULL, NULL
};
-/*
- * Type of Tcl_Objs used to speed up array searches.
- *
- * INTERNALREP DEFINITION:
- * twoPtrValue.ptr1: searchIdNumber (cast to pointer)
- * twoPtrValue.ptr2: variableNameStartInString (cast to pointer)
- *
- * Note that the value stored in ptr2 is the offset into the string of the
- * start of the variable name and not the address of the variable name itself,
- * as this can be safely copied.
- */
-
-const Tcl_ObjType tclArraySearchType = {
- "array search",
- NULL, NULL, NULL, SetArraySearchObj
-};
Var *
TclVarHashCreateVar(
@@ -521,16 +501,13 @@ TclObjLookupVarEx(
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
- const char *part1;
- int index, len1, len2;
- int parsed = 0;
- Tcl_Obj *objPtr;
- const Tcl_ObjType *typePtr = part1Ptr->typePtr;
const char *errMsg = NULL;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
+ int index, parsed = 0;
+ const Tcl_ObjType *typePtr = part1Ptr->typePtr;
+
*arrayPtrPtr = NULL;
if (typePtr == &localVarNameType) {
@@ -546,7 +523,7 @@ TclObjLookupVarEx(
*/
Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);
+ Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
(namePtr && (checkNamePtr == namePtr))) {
@@ -577,11 +554,7 @@ TclObjLookupVarEx(
}
return NULL;
}
- if ((part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2)) {
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
- }
+ part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2;
part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
if (typePtr == &localVarNameType) {
@@ -590,18 +563,23 @@ TclObjLookupVarEx(
}
parsed = 1;
}
- part1 = TclGetStringFromObj(part1Ptr, &len1);
- if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) {
+ if (!parsed) {
+
/*
* part1Ptr is possibly an unparsed array element.
*/
- register int i;
+ int len;
+ const char *part1 = TclGetStringFromObj(part1Ptr, &len);
+
+ if (len > 1 && (part1[len - 1] == ')')) {
+
+ const char *part2 = strchr(part1, '(');
+
+ if (part2) {
+ Tcl_Obj *arrayPtr;
- len2 = -1;
- for (i = 0; i < len1; i++) {
- if (*(part1 + i) == '(') {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
@@ -612,47 +590,19 @@ TclObjLookupVarEx(
return NULL;
}
- /*
- * part1Ptr points to an array element; first copy the element
- * name to a new string part2.
- */
+ arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
+ part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2);
- part2 = part1 + i + 1;
- len2 = len1 - i - 2;
- len1 = i;
+ TclFreeIntRep(part1Ptr);
- part2Ptr = Tcl_NewStringObj(part2, len2);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
-
- /*
- * Free the internal rep of the original part1Ptr, now renamed
- * objPtr, and set it to tclParsedVarNameType.
- */
-
- objPtr = part1Ptr;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclParsedVarNameType;
-
- /*
- * Define a new string object to hold the new part1Ptr, i.e.,
- * the array name. Set the internal rep of objPtr, reset
- * typePtr and part1 to contain the references to the array
- * name.
- */
-
- TclNewStringObj(part1Ptr, part1, len1);
- Tcl_IncrRefCount(part1Ptr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr;
- Tcl_IncrRefCount(part2Ptr);
- objPtr->internalRep.twoPtrValue.ptr2 = part2Ptr;
+ Tcl_IncrRefCount(arrayPtr);
+ part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr;
+ Tcl_IncrRefCount(part2Ptr);
+ part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr;
+ part1Ptr->typePtr = &tclParsedVarNameType;
- typePtr = part1Ptr->typePtr;
- part1 = TclGetString(part1Ptr);
- break;
- }
+ part1Ptr = arrayPtr;
+ }
}
}
@@ -662,8 +612,6 @@ TclObjLookupVarEx(
* the cached types if possible.
*/
- TclFreeIntRep(part1Ptr);
-
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
@@ -679,11 +627,12 @@ TclObjLookupVarEx(
* Cache the newly found variable if possible.
*/
+ TclFreeIntRep(part1Ptr);
if (index >= 0) {
/*
* An indexed local variable.
*/
- Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index);
+ Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
part1Ptr->typePtr = &localVarNameType;
if (part1Ptr != cachedNamePtr) {
@@ -2898,34 +2847,22 @@ TclArraySet(
*/
/* ARGSUSED */
-static int
-ArrayStartSearchCmd(
- ClientData clientData,
+
+static Var *
+VerifyArray(
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ Tcl_Obj *varNameObj)
{
Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
- Tcl_HashEntry *hPtr;
- Tcl_Obj *varNameObj;
- int isNew;
- ArraySearch *searchPtr;
- const char *varName;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
- return TCL_ERROR;
- }
- varNameObj = objv[1];
+ const char *varName = TclGetString(varNameObj);
+ Var *arrayPtr;
/*
* Locate the array variable.
*/
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- varName = TclGetString(varNameObj);
/*
* Special array trace used to keep the env array in sync for array names,
@@ -2937,7 +2874,7 @@ ArrayStartSearchCmd(
if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
+ return NULL;
}
}
@@ -2947,11 +2884,36 @@ ArrayStartSearchCmd(
* traces.
*/
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", varName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
+ return NULL;
+ }
+
+ return varPtr;
+}
+
+static int
+ArrayStartSearchCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+ ArraySearch *searchPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ varPtr = VerifyArray(interp, objv[1]);
+ if (varPtr == NULL) {
return TCL_ERROR;
}
@@ -2973,8 +2935,9 @@ ArrayStartSearchCmd(
searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
Tcl_SetHashValue(hPtr, searchPtr);
- Tcl_SetObjResult(interp,
- Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
+ searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
+ Tcl_IncrRefCount(searchPtr->name);
+ Tcl_SetObjResult(interp, searchPtr->name);
return TCL_OK;
}
@@ -3004,7 +2967,7 @@ ArrayAnyMoreCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
+ Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
int gotValue;
ArraySearch *searchPtr;
@@ -3016,39 +2979,8 @@ ArrayAnyMoreCmd(
varNameObj = objv[1];
searchObj = objv[2];
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
- }
-
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't an array", TclGetString(varNameObj)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
- TclGetString(varNameObj), NULL);
+ varPtr = VerifyArray(interp, varNameObj);
+ if (varPtr == NULL) {
return TCL_ERROR;
}
@@ -3110,8 +3042,7 @@ ArrayNextElementCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
+ Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
@@ -3122,39 +3053,8 @@ ArrayNextElementCmd(
varNameObj = objv[1];
searchObj = objv[2];
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
- }
-
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't an array", TclGetString(varNameObj)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
- TclGetString(varNameObj), NULL);
+ varPtr = VerifyArray(interp, varNameObj);
+ if (varPtr == NULL) {
return TCL_ERROR;
}
@@ -3220,7 +3120,7 @@ ArrayDoneSearchCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
+ Var *varPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr, *prevPtr;
@@ -3232,39 +3132,8 @@ ArrayDoneSearchCmd(
varNameObj = objv[1];
searchObj = objv[2];
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
- }
-
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't an array", TclGetString(varNameObj)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
- TclGetString(varNameObj), NULL);
+ varPtr = VerifyArray(interp, varNameObj);
+ if (varPtr == NULL) {
return TCL_ERROR;
}
@@ -3298,6 +3167,7 @@ ArrayDoneSearchCmd(
}
}
}
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
}
@@ -4937,75 +4807,6 @@ Tcl_UpvarObjCmd(
/*
*----------------------------------------------------------------------
*
- * SetArraySearchObj --
- *
- * This function converts the given tcl object into one that has the
- * "array search" internal type.
- *
- * Results:
- * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when
- * an error message will be placed in the interpreter's result.)
- *
- * Side effects:
- * Updates the internal type and representation of the object to make
- * this an array-search object. See the tclArraySearchType declaration
- * above for details of the internal representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetArraySearchObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- const char *string;
- char *end; /* Can't be const due to strtoul defn. */
- int id;
- size_t offset;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = TclGetString(objPtr);
-
- /*
- * Parse the id into the three parts separated by dashes.
- */
-
- if ((string[0] != 's') || (string[1] != '-')) {
- goto syntax;
- }
- id = strtoul(string+2, &end, 10);
- if ((end == (string+2)) || (*end != '-')) {
- goto syntax;
- }
-
- /*
- * Can't perform value check in this context, so place reference to place
- * in string to use for the check in the object instead.
- */
-
- end++;
- offset = end - string;
-
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclArraySearchType;
- objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id);
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset);
- return TCL_OK;
-
- syntax:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "illegal search identifier \"%s\"", string));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* ParseSearchId --
*
* This function translates from a tcl object to a pointer to an active
@@ -5016,10 +4817,6 @@ SetArraySearchObj(
* or NULL if there isn't one. If NULL is returned, the interp's result
* contains an error message.
*
- * Side effects:
- * The tcl object might have its internal type and representation
- * modified.
- *
*----------------------------------------------------------------------
*/
@@ -5035,65 +4832,43 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
- register const char *string;
- register size_t offset;
- int id;
ArraySearch *searchPtr;
- const char *varName = TclGetString(varNamePtr);
-
- /*
- * Parse the id.
- */
-
- if ((handleObj->typePtr != &tclArraySearchType)
- && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
- return NULL;
- }
-
- /*
- * Extract the information out of the Tcl_Obj.
- */
-
- id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1);
- string = TclGetString(handleObj);
- offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2);
-
- /*
- * This test cannot be placed inside the Tcl_Obj machinery, since it is
- * dependent on the variable context.
- */
-
- if (strcmp(string+offset, varName) != 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "search identifier \"%s\" isn't for variable \"%s\"",
- string, varName));
- goto badLookup;
- }
-
- /*
- * Search through the list of active searches on the interpreter to see if
- * the desired one exists.
- *
- * Note that we cannot store the searchPtr directly in the Tcl_Obj as that
- * would run into trouble when DeleteSearches() was called so we must scan
- * this list every time.
- */
+ const char *handle = TclGetString(handleObj);
+ char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+ /* First look for same (Tcl_Obj *) */
for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
- if (searchPtr->id == id) {
+ if (searchPtr->name == handleObj) {
return searchPtr;
}
}
+ /* Fallback: do string compares. */
+ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ searchPtr = searchPtr->nextPtr) {
+ if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
+ return searchPtr;
+ }
+ }
+ }
+ if ((handle[0] != 's') || (handle[1] != '-')
+ || (strtoul(handle + 2, &end, 10), end == (handle + 2))
+ || (*end != '-')) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal search identifier \"%s\"", handle));
+ } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "search identifier \"%s\" isn't for variable \"%s\"",
+ handle, TclGetString(varNamePtr)));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", handle));
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't find search \"%s\"", string));
- badLookup:
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL);
return NULL;
}
@@ -5128,6 +4903,7 @@ DeleteSearches(
for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
@@ -5180,13 +4956,16 @@ TclDeleteNamespaceVars(
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
- UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags,
- -1);
- Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
+ NULL, flags, -1);
/*
- * Remove the variable from the table and force it undefined in case
- * an unset trace brought it back from the dead.
+ * We just unset the variable. However, an unset trace might
+ * have re-set it, or might have re-established traces on it.
+ * This namespace and its vartable are going away unconditionally,
+ * so we cannot let such things linger. That would be a leak.
+ *
+ * First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
@@ -5210,6 +4989,17 @@ TclDeleteNamespaceVars(
}
}
}
+
+ /*
+ * ...and then, if the variable still holds a value, we unset it
+ * again. This time with no traces left, we're sure it goes away.
+ */
+
+ if (!TclIsVarUndefined(varPtr)) {
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
+ NULL, flags, -1);
+ }
+ Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
VarHashRefCount(varPtr)--;
VarHashDeleteEntry(varPtr);
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 10fa4f7..a7e8a8a 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2864,7 +2864,7 @@ ZlibTransformClose(
Tcl_Interp *interp)
{
ZlibChannelData *cd = instanceData;
- int e, result = TCL_OK;
+ int e, written, result = TCL_OK;
/*
* Delete the support timer.
@@ -2882,6 +2882,17 @@ ZlibTransformClose(
cd->outStream.next_out = (Bytef *) cd->outBuffer;
cd->outStream.avail_out = (unsigned) cd->outAllocated;
e = deflate(&cd->outStream, Z_FINISH);
+ written = cd->outAllocated - cd->outStream.avail_out;
+
+ /*
+ * Can't be sure that deflate() won't declare the buffer to be
+ * full (with Z_BUF_ERROR) so handle that case.
+ */
+
+ if (e == Z_BUF_ERROR) {
+ e = Z_OK;
+ written = cd->outAllocated;
+ }
if (e != Z_OK && e != Z_STREAM_END) {
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
@@ -2890,20 +2901,17 @@ ZlibTransformClose(
result = TCL_ERROR;
break;
}
- if (cd->outStream.avail_out != (unsigned) cd->outAllocated) {
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
- cd->outAllocated - cd->outStream.avail_out) < 0) {
- /* TODO: is this the right way to do errors on close?
- * Note: when close is called from FinalizeIOSubsystem
- * then interp may be NULL */
- if (!TclInThreadExit() && interp) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error while finalizing file: %s",
- Tcl_PosixError(interp)));
- }
- result = TCL_ERROR;
- break;
+ if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) {
+ /* TODO: is this the right way to do errors on close?
+ * Note: when close is called from FinalizeIOSubsystem then
+ * interp may be NULL */
+ if (!TclInThreadExit() && interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error while finalizing file: %s",
+ Tcl_PosixError(interp)));
}
+ result = TCL_ERROR;
+ break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->outStream);
@@ -3084,7 +3092,17 @@ ZlibTransformOutput(
e = deflate(&cd->outStream, Z_NO_FLUSH);
produced = cd->outAllocated - cd->outStream.avail_out;
- if (e == Z_OK && produced > 0) {
+ if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
+ /*
+ * deflate() indicates that it is out of space by returning
+ * Z_BUF_ERROR; in that case, we must write the whole buffer out
+ * and retry to compress what is left.
+ */
+
+ if (e == Z_BUF_ERROR) {
+ produced = cd->outAllocated;
+ e = Z_OK;
+ }
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
generated by cgit v0.12 at 2025-06-05 01:12:47 (GMT)