Index: .travis.yml ================================================================== --- .travis.yml +++ .travis.yml @@ -458,5 +458,6 @@ - export ERROR_ON_FAILURES=1 script: - make all tcltest - make test - make install + Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -963,13 +963,14 @@ hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr->refCount = 1; cmdPtr->hPtr = hPtr; + cmdPtr->refCount++; cmdPtr->nsPtr = iPtr->globalNsPtr; - cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; cmdPtr->objProc = cmdInfoPtr->objProc; @@ -2510,14 +2511,15 @@ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr->refCount = 1; Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; + cmdPtr->refCount++; cmdPtr->nsPtr = nsPtr; - cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->proc = proc; @@ -2755,14 +2757,17 @@ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *)ckalloc(sizeof(Command)); + cmdPtr->refCount = 1; + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->refCount++; + cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; - cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = TclInvokeObjectCommand; @@ -3475,10 +3480,11 @@ * three times, everything goes up in smoke. [Bug 1220058] */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); + TclCleanupCommandMacro(cmdPtr); cmdPtr->hPtr = NULL; } /* * Bump the command epoch counter. This will invalidate all cached @@ -3588,10 +3594,11 @@ * hash entry. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); + TclCleanupCommandMacro(cmdPtr); cmdPtr->hPtr = NULL; /* * Bump the command epoch counter. This will invalidate all cached * references that point to this command. Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -4982,10 +4982,21 @@ } while (0) #define TclRoutineHasName(cmdPtr) \ ((cmdPtr)->hPtr != NULL) + + +#define TclProcDecrRefCount(procPtr) \ + if ((procPtr)->refCount-- <= 1) { \ + TclProcCleanupProc(procPtr); \ + } + + +#define TclProcIncrRefCount(procPtr) \ + (procPtr)->refCount++; + /* *---------------------------------------------------------------- * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number * of calls out of the critical path. Note that this code isn't particularly Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -10,10 +10,11 @@ * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. * Copyright (c) 2006 Neil Madden. + * Copyright (c) 2018-2020 Nathan Coulter * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies @@ -957,11 +958,11 @@ } /* * If the namespace has associated ensemble commands, delete them first. * This leaves the actual contents of the namespace alone (unless they are - * linked ensemble commands, of course). Note that this code is actually + * linked ensemble commands, of course). This code is * reentrant so command delete traces won't purturb things badly. */ while (nsPtr->ensembles != NULL) { EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; @@ -1771,10 +1772,11 @@ DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; /* corresponding decrement is in DeleteImportedCmd */ cmdPtr->refCount++; dataPtr->selfPtr = (Command *) importedCmd; + dataPtr->selfPtr->refCount++; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import command @@ -1781,10 +1783,11 @@ * and add it to the import ref list in the "real" command. */ refPtr = (ImportRef *)ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->importedCmdPtr->refCount++; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { Command *overwrite = (Command *)Tcl_GetHashValue(found); @@ -1948,32 +1951,25 @@ /* *---------------------------------------------------------------------- * * TclGetOriginalCommand -- * - * An imported command is created in an namespace when a "real" command - * is imported from another namespace. If the specified command is an - * imported command, this function returns the original command it refers - * to. + * Returns the routine that an imported routine references, traversing any + * intermediate imported routines to find the origin routine. Returns NULL + * if the given routine is not imported. * * Results: - * If the command was imported into a sequence of namespaces a, b,...,n - * where each successive namespace just imports the command from the - * previous namespace, this function returns the Tcl_Command token in the - * first namespace, a. Otherwise, if the specified command is not an - * imported command, the function returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command TclGetOriginalCommand( - Tcl_Command command) /* The imported command for which the original - * command should be returned. */ + Tcl_Command command) /* A routine to find the original routine for */ { Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { @@ -2076,10 +2072,11 @@ if (prevPtr == NULL) { /* refPtr is first in list. */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; } + TclCleanupCommandMacro(refPtr->importedCmdPtr); ckfree(refPtr); TclCleanupCommandMacro(realCmdPtr); ckfree(dataPtr); return; } Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -721,10 +721,11 @@ nsPtr = nsPtr->parentPtr; } } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); + ((Command *)oPtr->command)->refCount++; /* * Add the NRE command and trace directly. While this breaks a number of * abstractions, it is faster and we're inside Tcl here so we're allowed. */ @@ -738,13 +739,15 @@ tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + ((Command *)oPtr->myCommand)->refCount++; oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); + ((Command *)oPtr->myclassCommand)->refCount++; return oPtr; } /* * ---------------------------------------------------------------------- @@ -784,19 +787,20 @@ MyDeleted( ClientData clientData) /* Reference to the object whose [my] has been * squelched. */ { Object *oPtr = (Object *)clientData; - + TclCleanupCommandMacro((Command *)oPtr->myCommand); oPtr->myCommand = NULL; } static void MyClassDeleted( ClientData clientData) { Object *oPtr = (Object *)clientData; + TclCleanupCommandMacro((Command *)oPtr->myclassCommand); oPtr->myclassCommand = NULL; } /* * ---------------------------------------------------------------------- @@ -837,10 +841,11 @@ */ if (!Destructing(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } + TclCleanupCommandMacro((Command *)oPtr->command); oPtr->command = NULL; TclOODecrRefCount(oPtr); return; } Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -68,11 +68,11 @@ }; #define ProcSetIntRep(objPtr, procPtr) \ do { \ Tcl_ObjIntRep ir; \ - (procPtr)->refCount++; \ + TclProcIncrRefCount((procPtr)); \ ir.twoPtrValue.ptr1 = (procPtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ } while (0) @@ -110,19 +110,21 @@ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + #define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ do { \ Tcl_ObjIntRep ir; \ ir.twoPtrValue.ptr1 = (procPtr); \ ir.twoPtrValue.ptr2 = (nsObjPtr); \ Tcl_IncrRefCount((nsObjPtr)); \ Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ } while (0) + #define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ do { \ const Tcl_ObjIntRep *irPtr; \ irPtr = TclFetchIntRep((objPtr), &lambdaType); \ @@ -189,10 +191,14 @@ "can't create procedure \"%s\": bad procedure name", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } + + + + /* * Create the data structure to represent the procedure. */ @@ -212,10 +218,14 @@ * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current * namespace if the proc was renamed into a different namespace. */ + ((Command *)cmd)->refCount++; + if (procPtr->cmdPtr != NULL) { + TclCleanupCommandMacro(procPtr->cmdPtr); + } procPtr->cmdPtr = (Command *) cmd; /* * TIP #280: Remember the line the procedure body is starting on. In a * bytecode context we ask the engine to provide us with the necessary @@ -310,12 +320,12 @@ } TclStackFree(interp, contextPtr); } /* - * Optimize for no-op procs: if the body is not precompiled (like a TclPro - * procbody), and the argument list is just "args" and the body is empty, + * Optimize for no-op procs: If the body is not precompiled, e.g like a TclPro + * procbody, the argument list is just "args", and the body is empty, * define a compileProc to compile a no-op. * * Notes: * - cannot be done for any argument list without having different * compiled/not-compiled behaviour in the "wrong argument #" case, or @@ -411,11 +421,11 @@ ProcGetIntRep(bodyPtr, procPtr); if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already - * compiled, and it is not shared with anyone else, so it's OK not to + * compiled not shared with anyone else, it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because * there may be no source code). * * We don't create and initialize a Proc structure for the procedure; * rather, we use what is in the body object. We increment the ref @@ -422,11 +432,17 @@ * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ procPtr->iPtr = iPtr; + + /* + * procPtr->cmdPtr is not incremented here because the caller provides + * their own cmdPtr. + */ procPtr->refCount++; + precompiled = 1; } else { /* * If the procedure's body object is shared because its string value * is identical to, e.g., the body of another procedure, we must @@ -468,10 +484,15 @@ Tcl_IncrRefCount(bodyPtr); procPtr = (Proc *)ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; + /* if cmdPtr isn't initialized to NULL here + * tclOOMethod.c:PushMethodCallFrame stores and attempts to use an + * invalid value in fdPtr->oldCmdPtr + */ + procPtr->cmdPtr = NULL; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; @@ -573,11 +594,11 @@ * Compare the parsed argument with the stored one. Note that the * only flag value that makes sense at this point is VAR_ARGUMENT * (its value was kept the same as pre VarReform to simplify * tbcload's processing of older byetcodes). * - * The only other flag vlaue that is important to retrieve from + * The only other flag value that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) @@ -664,11 +685,11 @@ *procPtrPtr = procPtr; return TCL_OK; procError: if (precompiled) { - procPtr->refCount--; + TclProcDecrRefCount(procPtr); } else { Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; @@ -1761,11 +1782,11 @@ /* * Invoke the commands in the procedure's body. */ - procPtr->refCount++; + TclProcIncrRefCount(procPtr); ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); @@ -1787,13 +1808,11 @@ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); } - if (procPtr->refCount-- <= 1) { - TclProcCleanupProc(procPtr); - } + TclProcDecrRefCount(procPtr); /* * Free the stack-allocated compiled locals and CallFrame. It is important * to pop the call frame without freeing it first: the compiledLocals * cannot be freed before the frame is popped, as the local variables must @@ -2095,14 +2114,12 @@ void TclProcDeleteProc( ClientData clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; - - if (procPtr->refCount-- <= 1) { - TclProcCleanupProc(procPtr); - } + TclProcDecrRefCount(procPtr); + return; } /* *---------------------------------------------------------------------- * @@ -2152,10 +2169,16 @@ Tcl_DecrRefCount(defPtr); } ckfree(localPtr); localPtr = nextPtr; } + /* + * TclOOMethod.c:clOOMakeProcMethod sets cmdPtr to NULL + */ + if (procPtr->cmdPtr) { + TclCleanupCommandMacro(procPtr->cmdPtr); + } ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for @@ -2269,12 +2292,12 @@ * * Results: * Returns a pointer to a newly allocated Tcl_Obj, NULL on error. * * Side effects: - * The reference count in the ByteCode attached to the Proc is bumped up - * by one, since the internal rep stores a pointer to it. + * The reference count in the procPtr is bumped up + * by one since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -2348,14 +2371,11 @@ Tcl_Obj *objPtr) /* The object to clean up. */ { Proc *procPtr; ProcGetIntRep(objPtr, procPtr); - - if (procPtr->refCount-- <= 1) { - TclProcCleanupProc(procPtr); - } + TclProcDecrRefCount(procPtr); } /* *---------------------------------------------------------------------- * @@ -2379,12 +2399,11 @@ Tcl_Obj *nsObjPtr; LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); assert(procPtr != NULL); - procPtr->refCount++; - + TclProcIncrRefCount(procPtr); LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void FreeLambdaInternalRep( @@ -2396,10 +2415,16 @@ LambdaGetIntRep(objPtr, procPtr, nsObjPtr); assert(procPtr != NULL); if (procPtr->refCount-- <= 1) { + /* + * procPtr->cmdPtr was not allocated but instead synthesized by + * TclNRApplyObjCmd. Tell TclProcCleanupProc() not to send it through + * the standard cleanup routine. + */ + procPtr->cmdPtr = NULL; TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); } @@ -2685,13 +2710,14 @@ extraPtr->efi.fields[0].name = "lambda"; extraPtr->efi.fields[0].proc = NULL; extraPtr->efi.fields[0].clientData = lambdaPtr; extraPtr->cmd.clientData = &extraPtr->efi; + TclProcIncrRefCount(procPtr); result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { - TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); + TclNRAddCallback(interp, ApplyNR2, extraPtr, procPtr, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); } return result; } @@ -2700,10 +2726,13 @@ ClientData data[], Tcl_Interp *interp, int result) { ApplyExtraData *extraPtr = (ApplyExtraData *)data[0]; + Proc *procPtr = (Proc *)data[1]; + procPtr->cmdPtr = NULL; + TclProcDecrRefCount(procPtr); TclStackFree(interp, extraPtr); return result; } Index: generic/tclTestProcBodyObj.c ================================================================== --- generic/tclTestProcBodyObj.c +++ generic/tclTestProcBodyObj.c @@ -211,11 +211,11 @@ * This command can be used to trigger the branches in Tcl_ProcObjCmd that * construct a proc from a "procbody", for example: * proc a {x} {return $x} * a 123 * procbodytest::proc b {x} a - * Note the call to "a 123", which is necessary so that the Proc pointer + * The call to "a 123" is necessary so that the Proc pointer * for "a" is filled in by the internal compiler; this is a hack. * * Results: * Returns a standard Tcl code. * Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -3662,10 +3662,47 @@ test interp-38.8 {interp debug basic setup} -body { interp debug {} -frame 0 bogus } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} + +test interp-39.0 { + no segmentation fault when a command is deleted +} -body { + variable res {} + + proc p1 args { + return success + } + namespace eval ns1 { + namespace export * + } + interp alias {} [namespace current]::ns1::p2 {} [namespace current]::p1 + namespace eval ns2 { + namespace import [namespace parent]::ns1::p2 + } + proc ondelete {oldname newname op} { + variable res + namespace delete ns1 + catch { + ns1::p2 + } res + } + + trace add command ns2::p2 delete [namespace which ondelete] + rename ns2::p2 {} + rename p1 {} + if { + [string match {*invalid command name*ns1::p2*} $res] + } { + return 1 + } else { + return $res + } +} -cleanup { +} -result 1 + # cleanup unset -nocomplain hidden_cmds foreach i [interp children] { interp delete $i Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -534,10 +534,55 @@ [list namespace forget [namespace current]::link2::cmd] my::cmd } -cleanup { namespace delete origin link link2 my } -returnCodes error -match glob -result * + + +test namespace-10.10 { + reference counting of target of imported command + + should not produce a memory error in Tcl built with -DPURIFY + --enable-symbols +} -body { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 args {} + } + namespace eval test_ns_import { + namespace import [namespace parent]::test_ns_export::cmd1 + } + proc test_ns_export::cmd1 args {} + namespace delete test_ns_export + return success +} -result success + + +test namespace-10.11 { + when a routine is replaced, the new routine becomes the target for any + imports of the old routine +} -body { + namespace eval ns1 { + namespace export * + + proc p1 {} { + return failure + } + } + + namespace eval ns2 { + namespace import [namespace parent]::ns1::p1 + } + proc ns1::p1 {} { + return success + } + set res [ns2::p1] + rename ns1::p1 {} + return $res +} -result success + + test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_export { Index: tests/proc.test ================================================================== --- tests/proc.test +++ tests/proc.test @@ -297,32 +297,58 @@ lappend rv [t S T U] } -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} -test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { - proc getbytes {} { - set lines [split [memory info] "\n"] - lindex $lines 3 3 - } - proc px x { - set y [string tolower $x] - return "$x:$y" - } - px x -} -constraints {procbodytest memory} -body { - set end [getbytes] - for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px - set tmp $end - set end [getbytes] - } - set leakedBytes [expr {$end - $tmp}] -} -cleanup { - rename getbytes {} - unset -nocomplain end i tmp leakedBytes -} -result 0 + + +try [string map { + @procpx@ { + proc px x { + set y [string tolower $x] + return $x:$y + } + px x + } + @cleanup@ { + unset -nocomplain end i tmp leakedBytes + } +} { + + test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { + proc getbytes {} { + set lines [split [memory info] \n] + lindex $lines 3 3 + } + @procpx@ + } -constraints {procbodytest memory} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + procbodytest::proc tx x px + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] + } -cleanup { + rename getbytes {} + @cleanup@ + } -result 0 + + + test proc-4.8.1 { + same as 4.8 but without the memory constraint so that valgrind can look + for leaks in tclTestProcBodyObj.c itself + } -setup { + @procpx@ + } -constraints procbodytest -body { + procbodytest::proc tx x px + return 0 + } -cleanup { + @cleanup@ + } -result 0 +}] + test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest { procbodytest::check } 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {