diff options
| -rw-r--r-- | generic/tclBasic.c | 20 | ||||
| -rw-r--r-- | generic/tclCompile.c | 2 | ||||
| -rw-r--r-- | generic/tclEnsemble.c | 8 | ||||
| -rw-r--r-- | generic/tclExecute.c | 20 | ||||
| -rw-r--r-- | generic/tclInt.h | 38 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 34 | ||||
| -rw-r--r-- | generic/tclOO.c | 2 | ||||
| -rw-r--r-- | generic/tclObj.c | 2 | ||||
| -rw-r--r-- | tests/namespace.test | 96 |
9 files changed, 48 insertions, 174 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 75f8527..4cc579b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2785,8 +2785,6 @@ TclCreateObjCommandInNs( Command *refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; - cmdPtr->refCount++; - TclCleanupCommandMacro(dataPtr->realCmdPtr); dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -3376,7 +3374,7 @@ Tcl_GetCommandFullName( * separator, and the command name. */ - if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) { + if (cmdPtr != NULL) { if (cmdPtr->nsPtr != NULL) { Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { @@ -3466,7 +3464,7 @@ Tcl_DeleteCommandFromToken( * and skip nested deletes. */ - if (cmdPtr->flags & CMD_DYING) { + if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash table * entry now, but don't invoke a callback or free the command @@ -3498,7 +3496,7 @@ Tcl_DeleteCommandFromToken( * be ignored. */ - cmdPtr->flags |= CMD_DYING; + cmdPtr->flags |= CMD_IS_DELETED; /* * Call trace functions for the command being deleted. Then delete its @@ -3528,7 +3526,7 @@ Tcl_DeleteCommandFromToken( } /* - * The list of commands exported from the namespace might have changed. + * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ @@ -3663,7 +3661,7 @@ CallCommandTraces( * While a rename trace is active, we will not process any more rename * traces; while a delete trace is active we will never reach here - * because Tcl_DeleteCommandFromToken checks for the condition - * (cmdPtr->flags & CMD_DYING) and returns immediately when a + * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a * command deletion is in progress. For all other traces, delete * traces will not be invoked but a call to TraceCommandProc will * ensure that tracePtr->clientData is freed whenever the command @@ -5216,7 +5214,7 @@ TEOV_RunLeaveTraces( int length; const char *command = TclGetStringFromObj(commandPtr, &length); - if (!(cmdPtr->flags & CMD_DYING)) { + if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -6462,7 +6460,7 @@ TclNREvalObjEx( /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care of the refCounts for + * we always make a copy. The callback takes care od the refCounts for * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. @@ -9515,7 +9513,7 @@ NRCoroutineCallerCallback( SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - if (cmdPtr->flags & CMD_DYING) { + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the * execEnv, this will do the complete cleanup. RewindCoroutine will @@ -10284,7 +10282,7 @@ TclInfoCoroutineCmd( return TCL_ERROR; } - if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { Tcl_Obj *namePtr; TclNewObj(namePtr); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7d67e12..fd63da3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1834,7 +1834,7 @@ CompileCmdLiteral( bytes = TclGetStringFromObj(cmdObj, &numBytes); cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); - if (cmdPtr && TclRoutineHasName(cmdPtr)) { + if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } TclEmitPush(cmdLitIdx, envPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 16bf8f7..3c99631 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3161,7 +3161,7 @@ TclCompileEnsemble( } /* - * Now that the mapping process is done we actually try to compile. + * Now we've done the mapping process, can now actually try to compile. * If there is a subcommand compiler and that successfully produces code, * we'll use that. Otherwise, we fall back to generating opcodes to do the * invoke at runtime. @@ -3261,9 +3261,9 @@ TclAttemptCompileProc( /* * Advance parsePtr->tokenPtr so that it points at the last subcommand. - * This will be wrong but it will not matter, and it will put the - * tokens for the arguments in the right place without the need to - * allocate a synthetic Tcl_Parse struct or copy tokens around. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ for (i = 0; i < depth - 1; i++) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 786fffb..0f1c2cc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4464,7 +4464,7 @@ TEBCresume( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; TclNewObj(objResultPtr); - if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, objResultPtr); } @@ -4524,18 +4524,6 @@ TEBCresume( TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); if (cmd == NULL) { - goto instOriginError; - } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } - - TclNewObj(objResultPtr); - Tcl_GetCommandFullName(interp, origCmd, objResultPtr); - if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) { - Tcl_DecrRefCount(objResultPtr); - instOriginError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); @@ -4545,6 +4533,12 @@ TEBCresume( TRACE_APPEND(("ERROR: not command\n")); goto gotError; } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); NEXT_INST_F(1, 1, 1); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2f12b8f..792b675 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1707,18 +1707,18 @@ typedef struct Command { /* * Flag bits for commands. * - * CMD_DYING - If 1 the command is in the process of + * CMD_IS_DELETED - Means that the command is in the process of * being deleted (its deleteProc is currently * executing). Other attempts to delete the * command should be ignored. - * CMD_TRACE_ACTIVE - If 1 the trace processing is currently + * CMD_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a rename/delete change. See the * two flags below for which is currently being * processed. - * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one * execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. - * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that + * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that * can handle expansion (provided it is not the * first word). * TCL_TRACE_RENAME - A rename trace is in progress. Further @@ -1728,7 +1728,7 @@ typedef struct Command { * (these last two flags are defined in tcl.h) */ -#define CMD_DYING 0x01 +#define CMD_IS_DELETED 0x01 #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -4960,30 +4960,10 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * the internal stubs, but the core can use the macro instead. */ -#define TclCleanupCommandMacro(cmdPtr) \ - do { \ - if ((cmdPtr)->refCount-- <= 1) { \ - ckfree(cmdPtr); \ - } \ - } while (0) - - -/* - * inside this routine crement refCount first incase cmdPtr is replacing itself - */ -#define TclRoutineAssign(location, cmdPtr) \ - do { \ - (cmdPtr)->refCount++; \ - if ((location) != NULL \ - && (location--) <= 1) { \ - ckfree(((location))); \ - } \ - (location) = (cmdPtr); \ - } while (0) - - -#define TclRoutineHasName(cmdPtr) \ - ((cmdPtr)->hPtr != NULL) +#define TclCleanupCommandMacro(cmdPtr) \ + if ((cmdPtr)->refCount-- <= 1) { \ + ckfree(cmdPtr);\ + } /* *---------------------------------------------------------------- diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 673acb0..26dca62 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1770,8 +1770,6 @@ DoImport( TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; - /* corresponding decrement is in DeleteImportedCmd */ - cmdPtr->refCount++; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); @@ -2079,7 +2077,6 @@ DeleteImportedCmd( prevPtr->nextPtr = refPtr->nextPtr; } ckfree(refPtr); - TclCleanupCommandMacro(realCmdPtr); ckfree(dataPtr); return; } @@ -3891,7 +3888,7 @@ NamespaceOriginCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Command cmd, origCmd; + Tcl_Command command, origCommand; Tcl_Obj *resultPtr; if (objc != 2) { @@ -3899,29 +3896,30 @@ NamespaceOriginCmd( return TCL_ERROR; } - cmd = Tcl_GetCommandFromObj(interp, objv[1]); - if (cmd == NULL) { - goto namespaceOriginError; - } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } - TclNewObj(resultPtr); - Tcl_GetCommandFullName(interp, origCmd, resultPtr); - if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) { - Tcl_DecrRefCount(resultPtr); - namespaceOriginError: + command = Tcl_GetCommandFromObj(interp, objv[1]); + if (command == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[1]), NULL); return TCL_ERROR; } + origCommand = TclGetOriginalCommand(command); + TclNewObj(resultPtr); + if (origCommand == NULL) { + /* + * The specified command isn't an imported command. Return the + * command's name qualified by the full name of the namespace it was + * defined in. + */ + + Tcl_GetCommandFullName(interp, command, resultPtr); + } else { + Tcl_GetCommandFullName(interp, origCommand, resultPtr); + } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - /* *---------------------------------------------------------------------- diff --git a/generic/tclOO.c b/generic/tclOO.c index 21018ac..85f4470 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1177,7 +1177,7 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_DYING) { + if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, diff --git a/generic/tclObj.c b/generic/tclObj.c index 44b2785..dbe6686 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4667,7 +4667,7 @@ SetCmdNameFromAny( * report the failure to find the command as an error. */ - if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) { + if (cmdPtr == NULL) { return TCL_ERROR; } diff --git a/tests/namespace.test b/tests/namespace.test index d09a853..8209cf3 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -618,102 +618,6 @@ test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { namespace delete src } {} - -test namespace-13.3 { - deleting origin of import in trace on deletion of import -} -setup { - namespace eval ns0 { - namespace export * - variable res {} - - proc traced {oldname newname op} { - variable res - - lappend res {Is oldname the name of the imported routine?} - set expected [namespace qualifiers [namespace current]::fake]::ns2::ns1 - if {$oldname eq $expected} { - lappend res 1 - } else { - lappend res 0 - } - - lappend res {[namespace which] finds the old name} - set which [namespace which $oldname] - if {$which eq $expected} { - lappend res 1 - } else { - lappend res $which - } - - lappend res {Is origin name correct} - catch { - namespace origin $oldname - } cres copts - set expected [namespace qualifiers [namespace current]::fake]::ns1 - if {$cres eq $expected} { - lappend res 1 - } else { - lappend res $cres - } - - set origin $cres - rename $origin {} - - lappend res {After deletion of the origin is it an error to ask for the origin (compiled)?} - set status [catch { - namespace origin $oldname - } cres copts] - if {$status && [string match {invalid command name "*::ns2::ns1"} $cres]} { - lappend res 1 - } else { - lappend res $cres - } - - lappend res {After deletion of the origin is it an error to ask for the origin (uncompiled)?} - set status [catch { - namespace eval [namespace current] "namespace origin $oldname" - } cres copts] - if {$status && [string match {invalid command name "*::ns2::ns1"} $cres]} { - lappend res 1 - } else { - lappend res $cres - } - - lappend res {after deletion of origin, [namespace which] on the imported routine returns the empty string} - set which [namespace which $oldname] - if {$which eq {}} { - lappend res 1 - } else { - lappend res $which - } - - return - } - - } -} -body { - namespace eval ns0::ns1 { - namespace ensemble create - } - - namespace eval ns0::ns2 { - namespace import [namespace parent]::ns1 - trace add command ns1 delete [namespace parent]::traced - rename ns1 {} - } - return $ns0::res -} -cleanup { - namespace delete ns0 -} -result [list \ - {Is oldname the name of the imported routine?} 1 \ - {[namespace which] finds the old name} 1 \ - {Is origin name correct} 1 \ - {After deletion of the origin is it an error to ask for the origin (compiled)?} 1 \ - {After deletion of the origin is it an error to ask for the origin (uncompiled)?} 1 \ - {after deletion of origin, [namespace which] on the imported routine returns the empty string} 1 \ -] - - test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 |