diff options
Diffstat (limited to 'unix/dltest')
| -rw-r--r-- | unix/dltest/Makefile.in | 8 | ||||
| -rw-r--r-- | unix/dltest/README | 6 | ||||
| -rw-r--r-- | unix/dltest/pkgua.c | 336 |
3 files changed, 345 insertions, 5 deletions
diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index bd30298..953ed18 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -1,7 +1,7 @@ # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.12 2003/04/03 22:13:00 mdejong Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.13 2004/02/24 22:58:48 dkf Exp $ TCL_DBGX = @TCL_DBGX@ CC = @CC@ @@ -21,7 +21,7 @@ CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} @touch ../dltest.marker pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c @@ -44,6 +44,10 @@ pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS} +pkgua${SHLIB_SUFFIX}: $(SRC_DIR)/pkgua.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c + ${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} + clean: rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status rm -f lib.exp ../dltest.marker diff --git a/unix/dltest/README b/unix/dltest/README index 12aa8be..3d85a9c 100644 --- a/unix/dltest/README +++ b/unix/dltest/README @@ -1,6 +1,6 @@ This directory contains several files for testing Tcl's dynamic -loading capabilities. If shared libraries are supported then -the build system in the parent directory will create +loading/unloading capabilities. If shared libraries are supported +then the build system in the parent directory will create the shared libs and load them into the tcltest executable. -RCS: @(#) $Id: README,v 1.3 2001/12/19 11:03:20 mdejong Exp $ +RCS: @(#) $Id: README,v 1.4 2004/02/24 22:58:48 dkf Exp $ diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c new file mode 100644 index 0000000..b4c9b6d --- /dev/null +++ b/unix/dltest/pkgua.c @@ -0,0 +1,336 @@ +/* + * 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.1 2004/02/24 22:58:48 dkf 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 int +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); +} |