/*
* 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.
*
* RCS: @(#) $Id: pkgua.c,v 1.2.2.1 2004/03/04 17:26:28 dgp Exp $
*/
#include "tcl.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int PkguaEqObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]));
static int PkguaQuoteObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]));
/*
* 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.
*
* Note that this code is utterly single-threaded.
*/
static Tcl_HashTable interpTokenMap;
static int interpTokenMapInitialised = 0;
#define MAX_REGISTERED_COMMANDS 2
static void
PkguaInitTokensHashTable(void)
{
if (interpTokenMapInitialised) {
return;
}
Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS);
interpTokenMapInitialised = 1;
}
static int
PkguaFreeTokensHashTable(void)
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search);
entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
}
interpTokenMapInitialised = 0;
}
static Tcl_Command *
PkguaInterpToTokens(interp)
Tcl_Interp *interp;
{
int newEntry;
Tcl_Command *cmdTokens;
Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(&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) {
cmdTokens[newEntry] = NULL;
}
Tcl_SetHashValue(entryPtr, (ClientData) cmdTokens);
} else {
cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr);
}
return cmdTokens;
}
static void
PkguaDeleteTokens(interp)
Tcl_Interp *interp;
{
Tcl_HashEntry *entryPtr =
Tcl_FindHashEntry(&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(dummy, interp, objc, objv)
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, n;
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(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj * CONST objv[]; /* Argument strings. */
{
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.
*
*----------------------------------------------------------------------
*/
int
Pkgua_Init(interp)
Tcl_Interp *interp; /* Interpreter in which the package is
* to be made available. */
{
int code, cmdIndex = 0;
Tcl_Command *cmdTokens;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
/*
* Initialise 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_SetVar(interp, "::pkgua_loaded", ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
cmdTokens[cmdIndex++] =
Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
cmdTokens[cmdIndex++] =
Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgua_SafeInit --
*
* This is a package initialization procedure, which is called
* by Tcl when this package is to be added to an unsafe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Pkgua_SafeInit(interp)
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 form an
* interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Pkgua_Unload(interp, flags)
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_SetVar(interp, "::pkgua_detached", ".", 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_SetVar(interp, "::pkgua_unloaded", ".", 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 form an
* interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Pkgua_SafeUnload(interp, flags)
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);
}