350 lines
8.8 KiB
C
350 lines
8.8 KiB
C
|
/*
|
|||
|
|
* pkgua.c --
|
|||
|
|
*
|
|||
|
|
* This file contains a simple Tcl package "pkgua" that is intended for
|
|||
|
|
* testing the Tcl dynamic unloading facilities.
|
|||
|
|
*
|
|||
|
|
* Copyright (c) 1995 Sun Microsystems, Inc.
|
|||
|
|
* Copyright (c) 2004 Georgios Petasis
|
|||
|
|
*
|
|||
|
|
* See the file "license.terms" for information on usage and redistribution of
|
|||
|
|
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
#undef STATIC_BUILD
|
|||
|
|
#include "tcl.h"
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Prototypes for procedures defined later in this file:
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
* the command tokens created by Tcl_CreateObjCommand in an interpreter,
|
|||
|
|
* indexed by the interpreter. In this way, we can find which command tokens
|
|||
|
|
* we have registered in a specific interpreter, in order to unload them. We
|
|||
|
|
* 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.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
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)
|
|||
|
|
{
|
|||
|
|
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
|
|||
|
|
|
|||
|
|
if (tsdPtr->interpTokenMapInitialised) {
|
|||
|
|
return;
|
|||
|
|
}
|
|||
|
|
Tcl_InitHashTable(&tsdPtr->interpTokenMap, TCL_ONE_WORD_KEYS);
|
|||
|
|
tsdPtr->interpTokenMapInitialised = 1;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static void
|
|||
|
|
PkguaFreeTokensHashTable(void)
|
|||
|
|
{
|
|||
|
|
Tcl_HashSearch search;
|
|||
|
|
Tcl_HashEntry *entryPtr;
|
|||
|
|
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
|
|||
|
|
|
|||
|
|
for (entryPtr = Tcl_FirstHashEntry(&tsdPtr->interpTokenMap, &search);
|
|||
|
|
entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
|
|||
|
|
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
|
|||
|
|
}
|
|||
|
|
tsdPtr->interpTokenMapInitialised = 0;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static Tcl_Command *
|
|||
|
|
PkguaInterpToTokens(
|
|||
|
|
Tcl_Interp *interp)
|
|||
|
|
{
|
|||
|
|
int newEntry;
|
|||
|
|
Tcl_Command *cmdTokens;
|
|||
|
|
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
|
|||
|
|
Tcl_HashEntry *entryPtr =
|
|||
|
|
Tcl_CreateHashEntry(&tsdPtr->interpTokenMap, (char *) interp, &newEntry);
|
|||
|
|
|
|||
|
|
if (newEntry) {
|
|||
|
|
cmdTokens = (Tcl_Command *)
|
|||
|
|
Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS));
|
|||
|
|
for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS ; ++newEntry) {
|
|||
|
|
cmdTokens[newEntry] = NULL;
|
|||
|
|
}
|
|||
|
|
Tcl_SetHashValue(entryPtr, cmdTokens);
|
|||
|
|
} else {
|
|||
|
|
cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr);
|
|||
|
|
}
|
|||
|
|
return cmdTokens;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static void
|
|||
|
|
PkguaDeleteTokens(
|
|||
|
|
Tcl_Interp *interp)
|
|||
|
|
{
|
|||
|
|
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)Tcl_GetThreadData((&dataKey), sizeof(ThreadSpecificData));
|
|||
|
|
Tcl_HashEntry *entryPtr =
|
|||
|
|
Tcl_FindHashEntry(&tsdPtr->interpTokenMap, (char *) interp);
|
|||
|
|
|
|||
|
|
if (entryPtr) {
|
|||
|
|
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
|
|||
|
|
Tcl_DeleteHashEntry(entryPtr);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* PkguaEqObjCmd --
|
|||
|
|
*
|
|||
|
|
* This procedure is invoked to process the "pkgua_eq" Tcl command. It
|
|||
|
|
* expects two arguments and returns 1 if they are the same, 0 if they
|
|||
|
|
* are different.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* A standard Tcl result.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* See the user documentation.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
static int
|
|||
|
|
PkguaEqObjCmd(
|
|||
|
|
ClientData dummy, /* Not used. */
|
|||
|
|
Tcl_Interp *interp, /* Current interpreter. */
|
|||
|
|
int objc, /* Number of arguments. */
|
|||
|
|
Tcl_Obj *const objv[]) /* Argument objects. */
|
|||
|
|
{
|
|||
|
|
int result;
|
|||
|
|
const char *str1, *str2;
|
|||
|
|
int len1, len2;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
if (objc != 3) {
|
|||
|
|
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
str1 = Tcl_GetStringFromObj(objv[1], &len1);
|
|||
|
|
str2 = Tcl_GetStringFromObj(objv[2], &len2);
|
|||
|
|
if (len1 == len2) {
|
|||
|
|
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
|
|||
|
|
} else {
|
|||
|
|
result = 0;
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* PkguaQuoteObjCmd --
|
|||
|
|
*
|
|||
|
|
* This procedure is invoked to process the "pkgua_quote" Tcl command. It
|
|||
|
|
* expects one argument, which it returns as result.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* A standard Tcl result.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* See the user documentation.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
static int
|
|||
|
|
PkguaQuoteObjCmd(
|
|||
|
|
ClientData dummy, /* Not used. */
|
|||
|
|
Tcl_Interp *interp, /* Current interpreter. */
|
|||
|
|
int objc, /* Number of arguments. */
|
|||
|
|
Tcl_Obj *const objv[]) /* Argument strings. */
|
|||
|
|
{
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
if (objc != 2) {
|
|||
|
|
Tcl_WrongNumArgs(interp, 1, objv, "value");
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, objv[1]);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Pkgua_Init --
|
|||
|
|
*
|
|||
|
|
* This is a package initialization procedure, which is called by Tcl
|
|||
|
|
* when this package is to be added to an interpreter.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
DLLEXPORT int
|
|||
|
|
Pkgua_Init(
|
|||
|
|
Tcl_Interp *interp) /* Interpreter in which the package is to be
|
|||
|
|
* made available. */
|
|||
|
|
{
|
|||
|
|
int code;
|
|||
|
|
Tcl_Command *cmdTokens;
|
|||
|
|
|
|||
|
|
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Initialize our Hash table, where we store the registered command tokens
|
|||
|
|
* for each interpreter.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
PkguaInitTokensHashTable();
|
|||
|
|
|
|||
|
|
code = Tcl_PkgProvide(interp, "pkgua", "1.0");
|
|||
|
|
if (code != TCL_OK) {
|
|||
|
|
return code;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
|
|||
|
|
|
|||
|
|
cmdTokens = PkguaInterpToTokens(interp);
|
|||
|
|
cmdTokens[0] =
|
|||
|
|
Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[0],
|
|||
|
|
CommandDeleted);
|
|||
|
|
cmdTokens[1] =
|
|||
|
|
Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,
|
|||
|
|
&cmdTokens[1], CommandDeleted);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Pkgua_SafeInit --
|
|||
|
|
*
|
|||
|
|
* This is a package initialization procedure, which is called by Tcl
|
|||
|
|
* when this package is to be added to a safe interpreter.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
DLLEXPORT int
|
|||
|
|
Pkgua_SafeInit(
|
|||
|
|
Tcl_Interp *interp) /* Interpreter in which the package is to be
|
|||
|
|
* made available. */
|
|||
|
|
{
|
|||
|
|
return Pkgua_Init(interp);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Pkgua_Unload --
|
|||
|
|
*
|
|||
|
|
* This is a package unloading initialization procedure, which is called
|
|||
|
|
* by Tcl when this package is to be unloaded from an interpreter.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
DLLEXPORT int
|
|||
|
|
Pkgua_Unload(
|
|||
|
|
Tcl_Interp *interp, /* Interpreter from which the package is to be
|
|||
|
|
* unloaded. */
|
|||
|
|
int flags) /* Flags passed by the unloading mechanism */
|
|||
|
|
{
|
|||
|
|
int code, cmdIndex;
|
|||
|
|
Tcl_Command *cmdTokens = PkguaInterpToTokens(interp);
|
|||
|
|
|
|||
|
|
for (cmdIndex=0 ; cmdIndex<MAX_REGISTERED_COMMANDS ; cmdIndex++) {
|
|||
|
|
if (cmdTokens[cmdIndex] == NULL) {
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
code = Tcl_DeleteCommandFromToken(interp, cmdTokens[cmdIndex]);
|
|||
|
|
if (code != TCL_OK) {
|
|||
|
|
return code;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
PkguaDeleteTokens(interp);
|
|||
|
|
|
|||
|
|
Tcl_SetVar2(interp, "::pkgua_detached", NULL, ".", TCL_APPEND_VALUE);
|
|||
|
|
|
|||
|
|
if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) {
|
|||
|
|
/*
|
|||
|
|
* Tcl is ready to detach this library from the running application.
|
|||
|
|
* We should free all the memory that is not related to any
|
|||
|
|
* interpreter.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
PkguaFreeTokensHashTable();
|
|||
|
|
Tcl_SetVar2(interp, "::pkgua_unloaded", NULL, ".", TCL_APPEND_VALUE);
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Pkgua_SafeUnload --
|
|||
|
|
*
|
|||
|
|
* This is a package unloading initialization procedure, which is called
|
|||
|
|
* by Tcl when this package is to be unloaded from an interpreter.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
DLLEXPORT int
|
|||
|
|
Pkgua_SafeUnload(
|
|||
|
|
Tcl_Interp *interp, /* Interpreter from which the package is to be
|
|||
|
|
* unloaded. */
|
|||
|
|
int flags) /* Flags passed by the unloading mechanism */
|
|||
|
|
{
|
|||
|
|
return Pkgua_Unload(interp, flags);
|
|||
|
|
}
|