From 64be4c1e63ef85d515bb28afe134159d649353f6 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sun, 23 Oct 2005 22:01:27 +0000 Subject: * generic/tclBasic.c: * generic/tclBinary.c: * generic/tclCmdAH.c: * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclExecute.c: * generic/tclLink.c: * generic/tclMain.c: * generic/tclProc.c: * generic/tclScan.c: * generic/tclTest.c: * generic/tclVar.c: * mac/tclMacInit.c: * unix/tclUnixInit.c: * win/tclWinInit.c: Insure that the core never calls TclPtrSetVar, Tcl_SetVar2Ex, Tcl_ObjSetVar2 or Tcl_SetObjErrorCode with a 0-ref new value. It is not possible to handle error returns correctly in that case [Bug 1334947], one has the choice of leaking the object in some cases, or else risk crashing in some others. --- ChangeLog | 22 +++++++++++++++++++++ generic/tclBasic.c | 22 +++++++++++++-------- generic/tclBinary.c | 16 +++++++++------ generic/tclCmdAH.c | 9 +++------ generic/tclCmdIL.c | 5 +++-- generic/tclCmdMZ.c | 19 ++++++++++++------ generic/tclExecute.c | 9 +++------ generic/tclLink.c | 56 ++++++++++++++++++++++++++++++++++++++-------------- generic/tclMain.c | 12 ++++++++--- generic/tclProc.c | 15 +++++++++----- generic/tclScan.c | 10 ++++++---- generic/tclTest.c | 5 +++-- generic/tclVar.c | 21 ++++++++------------ mac/tclMacInit.c | 4 +++- unix/tclUnixInit.c | 4 +++- win/tclWinInit.c | 4 +++- 16 files changed, 154 insertions(+), 79 deletions(-) diff --git a/ChangeLog b/ChangeLog index 095edc1..cc4795c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,25 @@ +2005-10-23 Miguel Sofer + + * generic/tclBasic.c: + * generic/tclBinary.c: + * generic/tclCmdAH.c: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclExecute.c: + * generic/tclLink.c: + * generic/tclMain.c: + * generic/tclProc.c: + * generic/tclScan.c: + * generic/tclTest.c: + * generic/tclVar.c: + * mac/tclMacInit.c: + * unix/tclUnixInit.c: + * win/tclWinInit.c: Insure that the core never calls TclPtrSetVar, + Tcl_SetVar2Ex, Tcl_ObjSetVar2 or Tcl_SetObjErrorCode with a 0-ref + new value. It is not possible to handle error returns correctly in + that case [Bug 1334947], one has the choice of leaking the object + in some cases, or else risk crashing in some others. + 2005-10-22 Miguel Sofer * generic/tclExecute.c (INST_CONCAT): disable the optimisation for diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 00673d5..4871844 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.75.2.17 2005/07/26 17:05:43 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.18 2005/10/23 22:01:28 msofer Exp $ */ #include "tclInt.h" @@ -5284,7 +5284,7 @@ Tcl_AddObjErrorInfo(interp, message, length) * NULL byte. */ { register Interp *iPtr = (Interp *) interp; - Tcl_Obj *messagePtr; + Tcl_Obj *objPtr; /* * If we are just starting to log an error, errorInfo is initialized @@ -5298,8 +5298,11 @@ Tcl_AddObjErrorInfo(interp, message, length) Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, iPtr->objResultPtr, TCL_GLOBAL_ONLY); } else { /* use the string result */ + objPtr = Tcl_NewStringObj(interp->result, -1); + Tcl_IncrRefCount(objPtr); Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, - Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY); + objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); } /* @@ -5308,8 +5311,11 @@ Tcl_AddObjErrorInfo(interp, message, length) */ if (!(iPtr->flags & ERROR_CODE_SET)) { + objPtr = Tcl_NewStringObj("NONE", -1); + Tcl_IncrRefCount(objPtr); Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, - Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY); + objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); } } @@ -5318,11 +5324,11 @@ Tcl_AddObjErrorInfo(interp, message, length) */ if (length != 0) { - messagePtr = Tcl_NewStringObj(message, length); - Tcl_IncrRefCount(messagePtr); + objPtr = Tcl_NewStringObj(message, length); + Tcl_IncrRefCount(objPtr); Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, - messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); - Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ + objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_DecrRefCount(objPtr); /* free msg object appended above */ } } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index cf83b99..fcc0061 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.13.2.3 2005/09/27 15:44:13 dkf Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" @@ -1083,12 +1083,13 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } valuePtr = Tcl_NewByteArrayObj(src, size); + Tcl_IncrRefCount(valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(valuePtr); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += count; @@ -1137,13 +1138,14 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) *dest++ = (char) ((value & 0x80) ? '1' : '0'); } } - + + Tcl_IncrRefCount(valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(valuePtr); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 7 ) / 8; @@ -1195,12 +1197,13 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } + Tcl_IncrRefCount(valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(valuePtr); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 1) / 2; @@ -1266,12 +1269,13 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count*size; } + Tcl_IncrRefCount(valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(valuePtr); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } break; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index aaf37ac..c3402ef 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.14 2005/10/13 21:45:32 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.15 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" @@ -1826,20 +1826,17 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) for (v = 0; v < varcList[i]; v++) { int k = index[i]++; Tcl_Obj *valuePtr, *varValuePtr; - int isEmptyObj = 0; if (k < argcList[i]) { valuePtr = argvList[i][k]; } else { valuePtr = Tcl_NewObj(); /* empty string */ - isEmptyObj = 1; } + Tcl_IncrRefCount(valuePtr); varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, valuePtr, 0); + Tcl_DecrRefCount(valuePtr); if (varValuePtr == NULL) { - if (isEmptyObj) { - Tcl_DecrRefCount(valuePtr); - } Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set loop variable: \"", diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index ab5c876..f38011b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.6 2005/07/29 14:57:26 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.7 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" @@ -933,10 +933,11 @@ InfoDefaultCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); + Tcl_IncrRefCount(nullObjPtr); valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, nullObjPtr, 0); + Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ if (valueObjPtr == NULL) { - Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ goto defStoreError; } Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1ab108f..d1cb609 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.20 2005/06/21 17:19:42 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.21 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" @@ -461,9 +461,10 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } } else { Tcl_Obj *valuePtr; + Tcl_IncrRefCount(newPtr); valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); + Tcl_DecrRefCount(newPtr); if (valuePtr == NULL) { - Tcl_DecrRefCount(newPtr); Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(objv[i]), "\"", (char *) NULL); return TCL_ERROR; @@ -1758,10 +1759,16 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) * Only set the failVarObj when we will return 0 * and we have indicated a valid fail index (>= 0) */ - if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + if ((result == 0) && (failVarObj != NULL)) { + Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat); + + Tcl_IncrRefCount(tmpPtr); + resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(tmpPtr); + if (resPtr == NULL) { + return TCL_ERROR; + } } Tcl_SetBooleanObj(resultPtr, result); break; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ef4b7d4..20f34e6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.94.2.15 2005/10/22 03:07:45 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.16 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" @@ -4038,9 +4038,7 @@ TclExecuteByteCode(interp, codePtr) valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { - int setEmptyStr = 0; if (valIndex >= listLen) { - setEmptyStr = 1; TclNewObj(valuePtr); } else { valuePtr = listRepPtr->elements[valIndex]; @@ -4068,16 +4066,15 @@ TclExecuteByteCode(interp, codePtr) } } else { DECACHE_STACK_INFO(); + Tcl_IncrRefCount(valuePtr); value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, valuePtr, TCL_LEAVE_ERR_MSG); + TclDecrRefCount(valuePtr); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", opnd, varIndex), Tcl_GetObjResult(interp)); - if (setEmptyStr) { - TclDecrRefCount(valuePtr); - } result = TCL_ERROR; goto checkForCatch; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 3476766..f31ad8e 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.8 2002/08/05 03:24:41 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.8.2.1 2005/10/23 22:01:30 msofer Exp $ */ #include "tclInt.h" @@ -95,7 +95,7 @@ Tcl_LinkVar(interp, varName, addr, type) * Also may have TCL_LINK_READ_ONLY * OR'ed in. */ { - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *resPtr; Link *linkPtr; int code; @@ -111,10 +111,12 @@ Tcl_LinkVar(interp, varName, addr, type) linkPtr->flags = 0; } objPtr = ObjValue(linkPtr); - if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_IncrRefCount(objPtr); + resPtr = Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(objPtr); + if (resPtr == NULL) { Tcl_DecrRefCount(linkPtr->varName); - Tcl_DecrRefCount(objPtr); ckfree((char *) linkPtr); return TCL_ERROR; } @@ -191,6 +193,7 @@ Tcl_UpdateLinkedVar(interp, varName) { Link *linkPtr; int savedFlag; + Tcl_Obj *objPtr; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); @@ -199,8 +202,10 @@ Tcl_UpdateLinkedVar(interp, varName) } savedFlag = linkPtr->flags & LINK_BEING_UPDATED; linkPtr->flags |= LINK_BEING_UPDATED; - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); + objPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -237,7 +242,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags) int changed, valueLength; CONST char *value; char **pp, *result; - Tcl_Obj *objPtr, *valueObj; + Tcl_Obj *objPtr, *valueObj, *tmpPtr; /* * If the variable is being unset, then just re-create it (with a @@ -249,8 +254,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); @@ -293,8 +301,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) return "internal error: bad linked variable type"; } if (changed) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); } return NULL; } @@ -309,8 +320,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ if (linkPtr->flags & LINK_READ_ONLY) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); return "linked variable is read-only"; } valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); @@ -331,8 +345,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_SetObjResult(interp, objPtr); - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); result = "variable must have integer value"; goto end; } @@ -343,8 +360,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w) != TCL_OK) { Tcl_SetObjResult(interp, objPtr); - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); result = "variable must have integer value"; goto end; } @@ -355,8 +375,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d) != TCL_OK) { Tcl_SetObjResult(interp, objPtr); - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); result = "variable must have real value"; goto end; } @@ -367,8 +390,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_SetObjResult(interp, objPtr); - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + tmpPtr = ObjValue(linkPtr); + Tcl_IncrRefCount(tmpPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpPtr); result = "variable must have boolean value"; goto end; } diff --git a/generic/tclMain.c b/generic/tclMain.c index 1b73be6..2847bd8 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.20.2.1 2005/09/30 19:28:55 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.20.2.2 2005/10/23 22:01:30 msofer Exp $ */ #include "tcl.h" @@ -210,6 +210,7 @@ Tcl_Main(argc, argv, appInitProc) Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString appName; + Tcl_Obj *objPtr; Tcl_FindExecutable(argv[0]); @@ -241,8 +242,11 @@ Tcl_Main(argc, argv, appInitProc) argc--; argv++; - Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); - + objPtr = Tcl_NewIntObj(argc); + Tcl_IncrRefCount(objPtr); + Tcl_SetVar2Ex(interp, "argc", NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); + argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_DString ds; @@ -251,7 +255,9 @@ Tcl_Main(argc, argv, appInitProc) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } + Tcl_IncrRefCount(argvPtr); Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(argvPtr); /* * Set the "tcl_interactive" variable. diff --git a/generic/tclProc.c b/generic/tclProc.c index 40c8ceb..2cb8be2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.44.2.2 2004/05/02 21:07:16 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.44.2.3 2005/10/23 22:01:30 msofer Exp $ */ #include "tclInt.h" @@ -1464,19 +1464,24 @@ TclUpdateReturnInfo(iPtr) { int code; char *errorCode; + Tcl_Obj *objPtr; code = iPtr->returnCode; iPtr->returnCode = TCL_OK; if (code == TCL_ERROR) { errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE"); + objPtr = Tcl_NewStringObj(errorCode, -1); + Tcl_IncrRefCount(objPtr); Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode, - NULL, Tcl_NewStringObj(errorCode, -1), - TCL_GLOBAL_ONLY); + NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); iPtr->flags |= ERROR_CODE_SET; if (iPtr->errorInfo != NULL) { + objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1); + Tcl_IncrRefCount(objPtr); Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo, - NULL, Tcl_NewStringObj(iPtr->errorInfo, -1), - TCL_GLOBAL_ONLY); + NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); iPtr->flags |= ERR_IN_PROGRESS; } } diff --git a/generic/tclScan.c b/generic/tclScan.c index 693fa60..19cec54 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.12.2.1 2004/08/19 21:12:04 dkf Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.12.2.2 2005/10/23 22:01:30 msofer Exp $ */ #include "tclInt.h" @@ -1168,15 +1168,17 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) */ for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { + Tcl_Obj *tmpPtr; + result++; - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, - objs[i], 0) == NULL) { + tmpPtr = Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0); + Tcl_DecrRefCount(objs[i]); + if (tmpPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set variable \"", Tcl_GetString(objv[i+3]), "\"", (char *) NULL); code = TCL_ERROR; } - Tcl_DecrRefCount(objs[i]); } } } else { diff --git a/generic/tclTest.c b/generic/tclTest.c index dbd2b8e..e02ba13 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.62.2.9 2004/08/16 14:18:25 msofer Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.62.2.10 2005/10/23 22:01:30 msofer Exp $ */ #define TCL_TEST @@ -3437,9 +3437,10 @@ TestregexpObjCmd(dummy, interp, objc, objv) info.matches[ii].end - 1); } } + Tcl_IncrRefCount(newPtr); valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + Tcl_DecrRefCount(newPtr); if (valuePtr == NULL) { - Tcl_DecrRefCount(newPtr); Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(varPtr), "\"", (char *) NULL); return TCL_ERROR; diff --git a/generic/tclVar.c b/generic/tclVar.c index a78b3f6..52fec78 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.69.2.8 2004/10/01 00:09:36 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.69.2.9 2005/10/23 22:01:31 msofer Exp $ */ #include "tclInt.h" @@ -2686,7 +2686,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValuePtr, *newValuePtr; register List *listRepPtr; register Tcl_Obj **elemPtrs; - int numElems, numRequired, createdNewObj, createVar, i, j; + int numElems, numRequired, createdNewObj, i, j; Var *varPtr, *arrayPtr; char *part1; @@ -2703,10 +2703,11 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) */ varValuePtr = Tcl_NewObj(); + Tcl_IncrRefCount(varValuePtr); newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varValuePtr); if (newValuePtr == NULL) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded object */ return TCL_ERROR; } } @@ -2719,12 +2720,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * the variable will now each only be called once. Also, if the * variable's old value is unshared we modify it directly, otherwise * we create a new copy to modify: this is "copy on write". - */ - - createdNewObj = 0; - createVar = 1; - - /* + * * Use the TCL_TRACE_READS flag to ensure that if we have an * array with no elements set yet, but with a read trace on it, * we will create the variable and get read traces triggered. @@ -2750,6 +2746,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) arrayPtr->refCount--; } + createdNewObj = 0; if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2757,7 +2754,6 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - createVar = (TclIsVarUndefined(varPtr)); varValuePtr = Tcl_NewObj(); createdNewObj = 1; } else if (Tcl_IsShared(varValuePtr)) { @@ -2824,12 +2820,11 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ + Tcl_IncrRefCount(varValuePtr); newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, varValuePtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varValuePtr); if (newValuePtr == NULL) { - if (createdNewObj && !createVar) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ - } return TCL_ERROR; } } diff --git a/mac/tclMacInit.c b/mac/tclMacInit.c index a319713..afae114 100644 --- a/mac/tclMacInit.c +++ b/mac/tclMacInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacInit.c,v 1.9.2.1 2004/03/29 18:49:36 hobbs Exp $ + * RCS: @(#) $Id: tclMacInit.c,v 1.9.2.2 2005/10/23 22:01:31 msofer Exp $ */ #include @@ -712,7 +712,9 @@ Tcl_Init( if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } + Tcl_IncrRefCount(pathPtr); Tcl_SetVar2Ex(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(pathPtr); return Tcl_Eval(interp, initCmd); } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index e63160d..3f4b454 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.34.2.9 2005/08/05 20:48:19 dkf Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.34.2.10 2005/10/23 22:01:31 msofer Exp $ */ #if defined(HAVE_COREFOUNDATION) @@ -963,7 +963,9 @@ Tcl_Init(interp) if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } + Tcl_IncrRefCount(pathPtr); Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(pathPtr); return Tcl_Eval(interp, initScript); } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index d7ddbb5..7fb65c2 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.40.2.5 2004/03/29 18:49:36 hobbs Exp $ + * RCS: @(#) $Id: tclWinInit.c,v 1.40.2.6 2005/10/23 22:01:31 msofer Exp $ */ #include "tclWinInt.h" @@ -847,7 +847,9 @@ Tcl_Init(interp) if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } + Tcl_IncrRefCount(pathPtr); Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(pathPtr); return Tcl_Eval(interp, initScript); } -- cgit v0.12