diff options
| -rw-r--r-- | doc/ParseArgs.3 | 2 | ||||
| -rw-r--r-- | doc/StringObj.3 | 2 | ||||
| -rw-r--r-- | generic/tclBasic.c | 19 | ||||
| -rw-r--r-- | generic/tclEnsemble.c | 4 | ||||
| -rw-r--r-- | generic/tclInt.h | 29 | ||||
| -rw-r--r-- | generic/tclLoad.c | 219 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 183 | ||||
| -rw-r--r-- | generic/tclTestObj.c | 3 | ||||
| -rw-r--r-- | generic/tclZipfs.c | 44 | ||||
| -rw-r--r-- | tests/namespace.test | 114 | ||||
| -rw-r--r-- | tests/pkgMkIndex.test | 4 | ||||
| -rw-r--r-- | tests/winDde.test | 3 | ||||
| -rw-r--r-- | unix/Makefile.in | 14 | ||||
| -rw-r--r-- | unix/dltest/pkgooa.c | 7 | ||||
| -rw-r--r-- | unix/dltest/pkgua.c | 53 | ||||
| -rw-r--r-- | unix/tclXtTest.c | 3 |
16 files changed, 465 insertions, 238 deletions
diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index 5ca9fa5..f29f161 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -191,7 +191,7 @@ came from, and so should be copied if it needs to be retained. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. .SH "REFERENCE COUNT MANAGEMENT" .PP -The values in the \fiobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have +The values in the \fIobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have their reference counts modified by this function. The interpreter result may be modified on error; the values passed should not be the interpreter result with no further reference added. diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 22e872a..772073e 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -385,7 +385,7 @@ cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. .SH "REFERENCE COUNT MANAGEMENT" .PP -\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fB, \fBTcl_Format\fR, +\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR, \fBTcl_ObjPrintf\fR, and \fBTcl_ConcatObj\fR always return a zero-reference object, much like \fBTcl_NewObj\fR. .PP diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5ca70d4..86d7960 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1826,28 +1826,28 @@ DeleteInterpProc( ckfree(hTablePtr); } - /* - * Invoke deletion callbacks; note that a callback can create new - * callbacks, so we iterate. - */ - while (iPtr->assocData != NULL) { + if (iPtr->assocData != NULL) { AssocData *dPtr; hTablePtr = iPtr->assocData; - iPtr->assocData = NULL; + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } + Tcl_DeleteHashEntry(hPtr); ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); ckfree(hTablePtr); + iPtr->assocData = NULL; } /* @@ -3505,15 +3505,14 @@ Tcl_DeleteCommandFromToken( cmdPtr->flags |= CMD_DYING; /* - * Call trace functions for the command being deleted. Then delete its - * traces. + * Call each functions and then delete the trace. */ cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; - /* Note that CallCommandTraces() never frees cmdPtr, that's + /* CallCommandTraces() does not cmdPtr, that's * done just before Tcl_DeleteCommandFromToken() returns */ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 929f3ef..ccd43b9 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -165,7 +165,7 @@ TclNamespaceEnsembleCmd( const char *simpleName; int index, done; - if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", @@ -1730,7 +1730,7 @@ NsEnsembleImplementationCmdNR( return TCL_ERROR; } - if (ensemblePtr->nsPtr->flags & NS_DYING) { + if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index b8ed3c1..ad9a5c1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -415,29 +415,27 @@ struct NamespacePathEntry { * Flags used to represent the status of a namespace: * * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace but there are still active call frames on the Tcl + * namespace. There may still be active call frames on the Tcl * stack that refer to the namespace. When the last call frame - * referring to it has been popped, it's variables and command - * will be destroyed and it will be marked "dead" (NS_DEAD). The - * namespace can no longer be looked up by name. + * referring to it has been popped, its remaining variables and + * commands are destroyed and it is marked "dead" (NS_DEAD). + * NS_TEARDOWN -1 means that TclTeardownNamespace has already been called on + * this namespace and it should not be called again [Bug 1355942]. * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace and no call frames still refer to it. Its variables - * and command have already been destroyed. This bit allows the - * namespace resolution code to recognize that the namespace is - * "deleted". When the last namespaceName object in any byte code - * unit that refers to the namespace has been freed (i.e., when - * the namespace's refCount is 0), the namespace's storage will - * be freed. - * NS_KILLED - 1 means that TclTeardownNamespace has already been called on - * this namespace and it should not be called again [Bug 1355942] + * namespace and no call frames still refer to it. It is no longer + * accessible by name. Its variables and commands have already + * been destroyed. When the last namespaceName object in any byte + * code unit that refers to the namespace has been freed (i.e., + * when the namespace's refCount is 0), the namespace's storage + * will be freed. * NS_SUPPRESS_COMPILATION - * Marks the commands in this namespace for not being compiled, * forcing them to be looked up every time. */ #define NS_DYING 0x01 -#define NS_DEAD 0x02 -#define NS_KILLED 0x04 +#define NS_TEARDOWN 0x02 +#define NS_DEAD 0x04 #define NS_SUPPRESS_COMPILATION 0x08 /* @@ -2958,6 +2956,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, diff --git a/generic/tclLoad.c b/generic/tclLoad.c index c9d1b31..ed2be03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -12,6 +12,7 @@ #include "tclInt.h" + /* * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call @@ -93,8 +94,20 @@ typedef struct InterpLibrary { * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc(ClientData clientData, - Tcl_Interp *interp); +static void LoadCleanupProc(ClientData clientData, + Tcl_Interp *interp); +static int IsStatic (LoadedLibrary *libraryPtr); +static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target, + LoadedLibrary *library, int keepLibrary, + const char *fullFileName, int interpExiting); + + +static int +IsStatic (LoadedLibrary *libraryPtr) { + int res; + res = (libraryPtr->fileName[0] == '\0'); + return res; +} /* *---------------------------------------------------------------------- @@ -547,12 +560,10 @@ Tcl_UnloadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedLibrary *libraryPtr, *defaultPtr; + LoadedLibrary *libraryPtr; Tcl_DString pfx, tmp; - Tcl_LibraryUnloadProc *unloadProc; InterpLibrary *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; - int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; const char *prefix; static const char *const options[] = { @@ -646,12 +657,11 @@ Tcl_UnloadObjCmd( * - Its prefix and file match the once we're looking for. * - Its file matches, and we weren't given a prefix. * - Its prefix matches, the file name was specified as empty, and there is - * only no statically loaded library with the same prefix. + * no statically loaded library with the same prefix. */ Tcl_MutexLock(&libraryMutex); - defaultPtr = NULL; for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { int namesMatch, filesMatch; @@ -677,9 +687,6 @@ Tcl_UnloadObjCmd( if (filesMatch && (namesMatch || (prefix == NULL))) { break; } - if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = libraryPtr; - } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { break; } @@ -741,6 +748,34 @@ Tcl_UnloadObjCmd( goto done; } + code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0); + + done: + Tcl_DStringFree(&pfx); + Tcl_DStringFree(&tmp); + if (!complain && (code != TCL_OK)) { + code = TCL_OK; + Tcl_ResetResult(interp); + } + return code; +} + +static int +UnloadLibrary( + Tcl_Interp *interp, + Tcl_Interp *target, + LoadedLibrary *libraryPtr, + int keepLibrary, + const char *fullFileName, + int interpExiting +) +{ + int code; + InterpLibrary *ipFirstPtr, *ipPtr; + LoadedLibrary *iterLibraryPtr; + int trustedRefCount = -1, safeRefCount = -1; + Tcl_LibraryUnloadProc *unloadProc = NULL; + /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If @@ -749,28 +784,34 @@ Tcl_UnloadObjCmd( if (Tcl_IsSafe(target)) { if (libraryPtr->safeUnloadProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a safe interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); - code = TCL_ERROR; - goto done; + if (!interpExiting) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); + code = TCL_ERROR; + goto done; + } } unloadProc = libraryPtr->safeUnloadProc; } else { if (libraryPtr->unloadProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a trusted interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); - code = TCL_ERROR; - goto done; + if (!interpExiting) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); + code = TCL_ERROR; + goto done; + } } unloadProc = libraryPtr->unloadProc; } + + /* * We are ready to unload the library. First, evaluate the unload * function. If this fails, we cannot proceed with unload. Also, we must @@ -781,34 +822,69 @@ Tcl_UnloadObjCmd( * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ - code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; - if (!keepLibrary) { - Tcl_MutexLock(&libraryMutex); - trustedRefCount = libraryPtr->interpRefCount; - safeRefCount = libraryPtr->safeInterpRefCount; - Tcl_MutexUnlock(&libraryMutex); + if (unloadProc == NULL) { + code = TCL_OK; + } else { + code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; + if (!keepLibrary) { + Tcl_MutexLock(&libraryMutex); + trustedRefCount = libraryPtr->interpRefCount; + safeRefCount = libraryPtr->safeInterpRefCount; + Tcl_MutexUnlock(&libraryMutex); - if (Tcl_IsSafe(target)) { - safeRefCount--; - } else { - trustedRefCount--; - } + if (Tcl_IsSafe(target)) { + safeRefCount--; + } else { + trustedRefCount--; + } - if (safeRefCount <= 0 && trustedRefCount <= 0) { - code = TCL_UNLOAD_DETACH_FROM_PROCESS; + if (safeRefCount <= 0 && trustedRefCount <= 0) { + code = TCL_UNLOAD_DETACH_FROM_PROCESS; + } } + code = unloadProc(target, code); } - code = unloadProc(target, code); + + if (code != TCL_OK) { Tcl_TransferResult(target, code, interp); goto done; } + + /* + * Remove this library from the interpreter's library cache. + */ + + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = ipFirstPtr; + if (ipPtr->libraryPtr == libraryPtr) { + ipFirstPtr = ipFirstPtr->nextPtr; + } else { + InterpLibrary *ipPrevPtr; + + for (ipPrevPtr = ipPtr; ipPtr != NULL; + ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { + if (ipPtr->libraryPtr == libraryPtr) { + ipPrevPtr->nextPtr = ipPtr->nextPtr; + break; + } + } + } + ckfree(ipPtr); + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); + + + if (IsStatic(libraryPtr)) { + goto done; + } + /* * The unload function executed fine. Examine the reference count to see * if we unload the DLL. */ + Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { libraryPtr->safeInterpRefCount--; @@ -850,51 +926,29 @@ Tcl_UnloadObjCmd( * it's been unloaded. */ - if (libraryPtr->fileName[0] != '\0') { + if (!IsStatic(libraryPtr)) { Tcl_MutexLock(&libraryMutex); if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ - defaultPtr = libraryPtr; - if (defaultPtr == firstLibraryPtr) { + iterLibraryPtr = libraryPtr; + if (iterLibraryPtr == firstLibraryPtr) { firstLibraryPtr = libraryPtr->nextPtr; } else { for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { - if (libraryPtr->nextPtr == defaultPtr) { - libraryPtr->nextPtr = defaultPtr->nextPtr; + if (libraryPtr->nextPtr == iterLibraryPtr) { + libraryPtr->nextPtr = iterLibraryPtr->nextPtr; break; } } } - /* - * Remove this library from the interpreter's library cache. - */ - - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = ipFirstPtr; - if (ipPtr->libraryPtr == defaultPtr) { - ipFirstPtr = ipFirstPtr->nextPtr; - } else { - InterpLibrary *ipPrevPtr; - - for (ipPrevPtr = ipPtr; ipPtr != NULL; - ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->libraryPtr == defaultPtr) { - ipPrevPtr->nextPtr = ipPtr->nextPtr; - break; - } - } - } - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, - ipFirstPtr); - ckfree(defaultPtr->fileName); - ckfree(defaultPtr->prefix); - ckfree(defaultPtr); - ckfree(ipPtr); + ckfree(iterLibraryPtr->fileName); + ckfree(iterLibraryPtr->prefix); + ckfree(iterLibraryPtr); Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; @@ -911,12 +965,6 @@ Tcl_UnloadObjCmd( } done: - Tcl_DStringFree(&pfx); - Tcl_DStringFree(&tmp); - if (!complain && (code != TCL_OK)) { - code = TCL_OK; - Tcl_ResetResult(interp); - } return code; } @@ -989,6 +1037,8 @@ Tcl_StaticLibrary( libraryPtr->loadHandle = NULL; libraryPtr->initProc = initProc; libraryPtr->safeInitProc = safeInitProc; + libraryPtr->unloadProc = NULL; + libraryPtr->safeUnloadProc = NULL; Tcl_MutexLock(&libraryMutex); libraryPtr->nextPtr = firstLibraryPtr; firstLibraryPtr = libraryPtr; @@ -1137,17 +1187,20 @@ TclGetLoadedLibraries( static void LoadCleanupProc( - ClientData clientData, /* Pointer to first InterpLibrary structure + TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure * for interp. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) { - InterpLibrary *ipPtr, *nextPtr; + InterpLibrary *ipPtr; + LoadedLibrary *libraryPtr; - ipPtr = (InterpLibrary *)clientData; - while (ipPtr != NULL) { - nextPtr = ipPtr->nextPtr; - ckfree(ipPtr); - ipPtr = nextPtr; + while (1) { + ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); + if (ipPtr == NULL) { + break; + } + libraryPtr = ipPtr->libraryPtr; + UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1); } } @@ -1192,7 +1245,7 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (libraryPtr->fileName[0] != '\0') { + if (!IsStatic(libraryPtr)) { Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); } #endif diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index f57b7e1..5dc9659 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -306,7 +306,7 @@ Tcl_PushCallFrame( /* * TODO: Examine whether it would be better to guard based on NS_DYING - * or NS_KILLED. It appears that these are not tested because they can + * or NS_TEARDOWN. It appears that these are not tested because they can * be set in a global interp that has been [namespace delete]d, but * which never really completely goes away because of lingering global * things like ::errorInfo and [::unknown] and hidden commands. @@ -986,20 +986,21 @@ Tcl_DeleteNamespace( } /* - * If the namespace is on the call frame stack, it is marked as "dying" - * (NS_DYING is OR'd into its flags): the namespace can't be looked up by - * name but its commands and variables are still usable by those active - * call frames. When all active call frames referring to the namespace - * have been popped from the Tcl stack, Tcl_PopCallFrame will call this - * function again to delete everything in the namespace. If no nsName - * objects refer to the namespace (i.e., if its refCount is zero), its - * commands and variables are deleted and the storage for its namespace - * structure is freed. Otherwise, if its refCount is nonzero, the - * namespace's commands and variables are deleted but the structure isn't - * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the - * namespace resolution code to recognize that the namespace is "deleted". - * The structure's storage is freed by FreeNsNameInternalRep when its - * refCount reaches 0. + * If the namespace is on the call frame stack, it is marked as "dying" + * (NS_DYING is OR'd into its flags): Contents of the namespace are + * still available and visible until the namespace is later marked as + * NS_DEAD, and its commands and variables are still usable by any + * active call frames referring to th namespace. When all active call + * frames referring to the namespace have been popped from the Tcl + * stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no + * nsName objects refer to the namespace (i.e., if its refCount is + * zero), its commands and variables are deleted and the storage for + * its namespace structure is freed. Otherwise, if its refCount is + * nonzero, the namespace's commands and variables are deleted but the + * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's + * flags to allow the namespace resolution code to recognize that the + * namespace is "deleted". The structure's storage is freed by + * FreeNsNameInternalRep when its refCount reaches 0. */ if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { @@ -1013,16 +1014,16 @@ Tcl_DeleteNamespace( } } nsPtr->parentPtr = NULL; - } else if (!(nsPtr->flags & NS_KILLED)) { + } else if (!(nsPtr->flags & NS_TEARDOWN)) { /* * Delete the namespace and everything in it. If this is the global * namespace, then clear it but don't free its storage unless the - * interpreter is being torn down. Set the NS_KILLED flag to avoid + * interpreter is being torn down. Set the NS_TEARDOWN flag to avoid * recursive calls here - if the namespace is really in the process of * being deleted, ignore any second call. */ - nsPtr->flags |= (NS_DYING|NS_KILLED); + nsPtr->flags |= (NS_DYING|NS_TEARDOWN); TclTeardownNamespace(nsPtr); @@ -1060,7 +1061,7 @@ Tcl_DeleteNamespace( * get killed later, avoiding mem leaks. */ - nsPtr->flags &= ~(NS_DYING|NS_KILLED); + nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN); } } TclNsDecrRefCount(nsPtr); @@ -1073,6 +1074,83 @@ TclNamespaceDeleted( return (nsPtr->flags & NS_DYING) ? 1 : 0; } +void +TclDeleteNamespaceChildren( + Namespace *nsPtr /* Namespace whose children to delete */ +) +{ + Interp *iPtr = (Interp *) nsPtr->interp; + Tcl_HashEntry *entryPtr; + int i, unchecked; + Tcl_HashSearch search; + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it divorces itself from its + * parent. The hash table can't be proplery traversed if its elements are + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) copy to a temporary array and then delete all those + * namespaces. + * + * Important: leave the hash table itself still live. + */ + +#ifndef BREAK_NAMESPACE_COMPAT + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTable.numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } +#else + if (nsPtr->childTablePtr != NULL) { + unchecked = (nsPtr->childTable.numEntries > 0); + while (nsPtr->childTable.numEntries > 0 && unchecked) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + unchecked = 0; + for (i = 0 ; i < length ; i++) { + if (!(children[i]->flags & NS_DYING)) { + unchecked = 1; + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + } + TclStackFree((Tcl_Interp *) iPtr, children); + } + } +#endif +} + /* *---------------------------------------------------------------------- * @@ -1181,62 +1259,7 @@ TclTeardownNamespace( nsPtr->commandPathSourceList = NULL; } - /* - * Delete all the child namespaces. - * - * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - int length = nsPtr->childTable.numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = (Namespace *)Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } -#else - if (nsPtr->childTablePtr != NULL) { - while (nsPtr->childTablePtr->numEntries > 0) { - int length = nsPtr->childTablePtr->numEntries; - Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Namespace *) * length); - - i = 0; - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - children[i] = Tcl_GetHashValue(entryPtr); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif + TclDeleteNamespaceChildren(nsPtr); /* * Free the namespace's export pattern array. @@ -2618,7 +2641,7 @@ Tcl_FindCommand( &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL)) { if ((cxtNsPtr == realNsPtr) - || !(realNsPtr->flags & NS_DYING)) { + || !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -2630,7 +2653,7 @@ Tcl_FindCommand( * Next, check along the path. */ - for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { + for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) { pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; @@ -2639,7 +2662,7 @@ Tcl_FindCommand( TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -2657,7 +2680,7 @@ Tcl_FindCommand( TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & NS_DYING)) { + && !(realNsPtr->flags & NS_DEAD)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); @@ -3277,7 +3300,7 @@ NamespaceDeleteCmd( name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) - || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { + || (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\" in namespace delete command", TclGetString(objv[i]))); diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 17546a4..f766030 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -54,14 +54,13 @@ static Tcl_ObjCmdProc TeststringobjCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 -static void VarPtrDeleteProc(void *clientData, Tcl_Interp *interp) +static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *)) { int i; Tcl_Obj **varPtr = (Tcl_Obj **) clientData; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]); } - Tcl_DeleteAssocData(interp, VARPTR_KEY); ckfree(varPtr); } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 8706d5a..35b6712 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -249,7 +249,7 @@ typedef struct ZipChannel { * Most are kept in single ZipFS struct. When build with threading support * this struct is protected by the ZipFSMutex (see below). * - * The "fileHash" component is the process wide global table of all known ZIP + * The "fileHash" component is the process-wide global table of all known ZIP * archive members in all mounted ZIP archives. * * The "zipHash" components is the process wide global table of all mounted @@ -346,7 +346,9 @@ static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf, void *handle); static void ZipfsExitHandler(ClientData clientData); +static void ZipfsMountExitHandler(ClientData clientData); static void ZipfsSetup(void); +static void ZipfsFinalize(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp, int flags); static Tcl_DriverGetHandleProc ZipChannelGetFile; @@ -1613,7 +1615,7 @@ ZipFSCatalogFilesystem( */ zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr); - Tcl_CreateExitHandler(ZipfsExitHandler, zf); + Tcl_CreateExitHandler(ZipfsMountExitHandler, zf); zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); @@ -1855,6 +1857,7 @@ ZipfsSetup(void) strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); ZipFS.utf8 = Tcl_GetEncoding(NULL, "utf-8"); ZipFS.initialized = 1; + Tcl_CreateExitHandler(ZipfsExitHandler, NULL); } /* @@ -2178,7 +2181,7 @@ TclZipfs_Unmount( ckfree(z); } ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsExitHandler, zf); + Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf); ckfree(zf); unmounted = 1; @@ -5730,13 +5733,48 @@ ZipfsAppHookFindTclInit( static void ZipfsExitHandler( + TCL_UNUSED(ClientData) +) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + if (ZipFS.initialized != -1) { + hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + if (hPtr == NULL) { + ZipfsFinalize(); + } else { + /* ZipFS.fallbackEntryEncoding was already freed by + * ZipfsMountExitHandler + */ + } + } +} + +static void +ZipfsFinalize(void) { + Tcl_DeleteHashTable(&ZipFS.fileHash); + ckfree(ZipFS.fallbackEntryEncoding); + ZipFS.initialized = -1; +} + +static void +ZipfsMountExitHandler( ClientData clientData) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf = (ZipFile *) clientData; if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { Tcl_Panic("tried to unmount busy filesystem"); } + + hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + if (hPtr == NULL) { + ZipfsFinalize(); + } + } /* diff --git a/tests/namespace.test b/tests/namespace.test index efd00a8..64f237d 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -182,8 +182,8 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} } {} test namespace-7.7 {Bug 1655305} -setup { interp create child - # Can't invoke through the ensemble, since deleting the global namespace - # (indirectly, via deleting ::tcl) deletes the ensemble. + # Can't invoke through the ensemble, since deleting ::tcl + # (indirectly, via deleting the global namespace) deletes the ensemble. child eval {rename ::tcl::info::commands ::infocommands} child hide infocommands child eval { @@ -207,10 +207,72 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols. namespace delete ns1 } -result {} + +test namespace-7.9 { + Bug e39cb3f462631a99 + + A namespace being deleted should not be removed from other namespace paths + until the contents of the namespace are entirely removed. +} -setup { + + + + +} -body { + + variable res {} + + + namespace eval ns1 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + + namespace eval ns1a { + namespace path [namespace parent]::ns1 + + proc t1 {old new op} { + $old t1 + } + } + + namespace eval ns2 { + proc p1 caller { + lappend [namespace parent]::res $caller + } + } + + namespace eval ns2a { + namespace path [namespace parent]::ns2 + + proc t1 {old new op} { + [namespace tail $old] t2 + } + } + + + trace add command ns1::p1 delete ns1a::t1 + namespace delete ns1 + + trace add command ns2::p1 delete ns2a::t1 + namespace delete ns2 + + return $res + +} -cleanup { + namespace delete ns1a + namespace delete ns2a + unset res +} -result {t1 t2} + + + test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -2723,7 +2785,11 @@ test namespace-51.12 {name resolution path control} -body { catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } -test namespace-51.13 {name resolution path control} -body { +test namespace-51.13 { + name resolution path control + when the trace fires, ns_2 is being deleted but isn't gone yet, and is + still visible for the trace +} -body { set ::result {} namespace eval ::test_ns_1 { proc foo {} {lappend ::result 1} @@ -2746,8 +2812,7 @@ test namespace-51.13 {name resolution path control} -body { } bar } - # Should the result be "2 {} {2 3 2 1}" instead? -} -result {2 {} {2 3 1 1}} -cleanup { +} -result {2 {} {2 3 2 1}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} @@ -3340,6 +3405,43 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup { } -result 1 +test namespace-56.6 { + Namespace deletion traces on both the original routine and the imported + routine should run without any memory error under a debug build. +} -body { + variable res {} + + proc ondelete {old new op} { + variable res + set tail [namespace tail $old] + set up [namespace tail [namespace qualifiers $old]] + lappend res [list $up $tail] + } + + + namespace eval ns1 {} { + namespace export * + proc p1 {} { + namespace upvar [namespace parent] res res + incr res + } + trace add command p1 delete ondelete + } + + namespace eval ns2 {} { + namespace import [namespace parent]::ns1::p1 + trace add command p1 delete ondelete + } + + namespace delete ns1 + namespace delete ns2 + after 1 + return $res +} -cleanup { + unset res + rename ondelete {} +} -result {{ns1 p1} {ns2 p1}} + test namespace-57.0 { an imported alias should be usable in the deletion trace for the alias diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index df49c32..62bd3d4 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl } "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" + test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can # delete the file and not get stuck because we're holding a reference to # it. # # This test depends on context from prior test, so repeat it. + set script \ "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" append script \n \ "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] -} {0 {}} +} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}" if {[testConstraint $dll]} { file delete -force [file join $fullPkgPath [file tail $x]] diff --git a/tests/winDde.test b/tests/winDde.test index f57a226..925574b 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -37,6 +37,7 @@ proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] + fconfigure $f -encoding utf-8 puts $f [list set ddeServerName $ddeServerName] puts $f [list load $::ddelib Dde] puts $f { @@ -96,7 +97,7 @@ proc createChildProcess {ddeServerName args} { # run the child server script. set f [open |[list [interpreter] $::scriptName] r] - fconfigure $f -buffering line + fconfigure $f -buffering line -encoding utf-8 gets $f line return $f } diff --git a/unix/Makefile.in b/unix/Makefile.in index 5a06a1d..17e70d9 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -268,6 +268,7 @@ TRACE_OPTS = VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=24 \ --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ + --keep-debuginfo=yes \ --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- @@ -902,18 +903,13 @@ test-tcl: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) gdb-test: ${TCLTEST_EXE} - @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run - @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run - @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run - $(GDB) ./${TCLTEST_EXE} --command=gdb.run - @rm gdb.run + $(SHELL_ENV) $(GDB) --args ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \ + $(TESTFLAGS) -singleproc 1 lldb-test: ${TCLTEST_EXE} - @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run - @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run - $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \ + $(SHELL_ENV) $(LLDB) -- ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \ $(TESTFLAGS) -singleproc 1 - @rm lldb.run + # Useful target to launch a built tcltest with the proper path,... runtest: ${TCLTEST_EXE} diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index ff1cf1f..5aa48a5 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -84,10 +84,13 @@ static TclOOStubs stubsCopy = { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, - NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL +#ifdef Tcl_MethodIsPrivate + ,NULL +#endif }; -extern DLLEXPORT int +DLLEXPORT int Pkgooa_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 0ab3e23..a822541 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -21,6 +21,7 @@ static int PkguaEqObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PkguaQuoteObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static void CommandDeleted(ClientData clientData); /* * In the following hash table we are going to store a struct that holds all @@ -30,23 +31,32 @@ static int PkguaQuoteObjCmd(ClientData clientData, * need to keep the various command tokens we have registered, as they are the * only safe way to unregister our registered commands, even if they have been * renamed. - * - * Note that this code is utterly single-threaded. */ -static Tcl_HashTable interpTokenMap; -static int interpTokenMapInitialised = 0; +typedef struct ThreadSpecificData { + int interpTokenMapInitialised; + Tcl_HashTable interpTokenMap; +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; #define MAX_REGISTERED_COMMANDS 2 +static void +CommandDeleted(ClientData clientData) +{ + Tcl_Command *cmdToken = (Tcl_Command *)clientData; + *cmdToken = NULL; +} static void PkguaInitTokensHashTable(void) { - if (interpTokenMapInitialised) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); + + if (tsdPtr->interpTokenMapInitialised) { return; } - Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); - interpTokenMapInitialised = 1; + Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS); + tsdPtr->interpTokenMapInitialised = 1; } static void @@ -54,12 +64,13 @@ PkguaFreeTokensHashTable(void) { Tcl_HashSearch search; Tcl_HashEntry *entryPtr; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); - for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); + for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); } - interpTokenMapInitialised = 0; + tsdPtr->interpTokenMapInitialised = 0; } static Tcl_Command * @@ -68,13 +79,14 @@ PkguaInterpToTokens( { int newEntry; Tcl_Command *cmdTokens; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry); + Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry); if (newEntry) { cmdTokens = (Tcl_Command *) - Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); - for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) { + Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS)); + for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS ; ++newEntry) { cmdTokens[newEntry] = NULL; } Tcl_SetHashValue(entryPtr, cmdTokens); @@ -88,8 +100,9 @@ static void PkguaDeleteTokens( Tcl_Interp *interp) { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData)); Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&interpTokenMap, interp); + Tcl_FindHashEntry(&tsdPtr->interpTokenMap, (char *) interp); if (entryPtr) { Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); @@ -199,7 +212,7 @@ Pkgua_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ { - int code, cmdIndex = 0; + int code; Tcl_Command *cmdTokens; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { @@ -207,7 +220,7 @@ Pkgua_Init( } /* - * Initialise our Hash table, where we store the registered command tokens + * Initialize our Hash table, where we store the registered command tokens * for each interpreter. */ @@ -221,12 +234,12 @@ Pkgua_Init( Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE); cmdTokens = PkguaInterpToTokens(interp); - cmdTokens[cmdIndex++] = - Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL, - NULL); - cmdTokens[cmdIndex++] = + cmdTokens[0] = + Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0], + CommandDeleted); + cmdTokens[1] = Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, - NULL, NULL); + &cmdTokens[1], CommandDeleted); return TCL_OK; } diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 4ee7cca..882f497 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -16,7 +16,6 @@ #include "tcl.h" static Tcl_ObjCmdProc TesteventloopCmd; -extern DLLEXPORT Tcl_LibraryInitProc Tclxttest_Init; /* * Functions defined in tclXtNotify.c for use by users of the Xt Notifier: @@ -44,7 +43,7 @@ extern XtAppContext TclSetAppContext(XtAppContext ctx); *---------------------------------------------------------------------- */ -int +DLLEXPORT int Tclxttest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { |