1/* 2 * pkgua.c -- 3 * 4 * This file contains a simple Tcl package "pkgua" that is intended for 5 * testing the Tcl dynamic unloading facilities. 6 * 7 * Copyright (c) 1995 Sun Microsystems, Inc. 8 * Copyright (c) 2004 Georgios Petasis 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: pkgua.c,v 1.7 2007/12/13 15:28:43 dgp Exp $ 14 */ 15 16#include "tcl.h" 17 18/* 19 * Prototypes for procedures defined later in this file: 20 */ 21 22static int PkguaEqObjCmd(ClientData clientData, 23 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); 24static int PkguaQuoteObjCmd(ClientData clientData, 25 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); 26 27/* 28 * In the following hash table we are going to store a struct that holds all 29 * the command tokens created by Tcl_CreateObjCommand in an interpreter, 30 * indexed by the interpreter. In this way, we can find which command tokens 31 * we have registered in a specific interpreter, in order to unload them. We 32 * need to keep the various command tokens we have registered, as they are the 33 * only safe way to unregister our registered commands, even if they have been 34 * renamed. 35 * 36 * Note that this code is utterly single-threaded. 37 */ 38 39static Tcl_HashTable interpTokenMap; 40static int interpTokenMapInitialised = 0; 41#define MAX_REGISTERED_COMMANDS 2 42 43 44static void 45PkguaInitTokensHashTable(void) 46{ 47 if (interpTokenMapInitialised) { 48 return; 49 } 50 Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); 51 interpTokenMapInitialised = 1; 52} 53 54void 55PkguaFreeTokensHashTable(void) 56{ 57 Tcl_HashSearch search; 58 Tcl_HashEntry *entryPtr; 59 60 for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); 61 entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { 62 Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); 63 } 64 interpTokenMapInitialised = 0; 65} 66 67static Tcl_Command * 68PkguaInterpToTokens( 69 Tcl_Interp *interp) 70{ 71 int newEntry; 72 Tcl_Command *cmdTokens; 73 Tcl_HashEntry *entryPtr = 74 Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry); 75 76 if (newEntry) { 77 cmdTokens = (Tcl_Command *) 78 Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); 79 for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) { 80 cmdTokens[newEntry] = NULL; 81 } 82 Tcl_SetHashValue(entryPtr, (ClientData) cmdTokens); 83 } else { 84 cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr); 85 } 86 return cmdTokens; 87} 88 89static void 90PkguaDeleteTokens( 91 Tcl_Interp *interp) 92{ 93 Tcl_HashEntry *entryPtr = 94 Tcl_FindHashEntry(&interpTokenMap, (char *) interp); 95 96 if (entryPtr) { 97 Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); 98 Tcl_DeleteHashEntry(entryPtr); 99 } 100} 101 102/* 103 *---------------------------------------------------------------------- 104 * 105 * PkguaEqObjCmd -- 106 * 107 * This procedure is invoked to process the "pkgua_eq" Tcl command. It 108 * expects two arguments and returns 1 if they are the same, 0 if they 109 * are different. 110 * 111 * Results: 112 * A standard Tcl result. 113 * 114 * Side effects: 115 * See the user documentation. 116 * 117 *---------------------------------------------------------------------- 118 */ 119 120static int 121PkguaEqObjCmd( 122 ClientData dummy, /* Not used. */ 123 Tcl_Interp *interp, /* Current interpreter. */ 124 int objc, /* Number of arguments. */ 125 Tcl_Obj *CONST objv[]) /* Argument objects. */ 126{ 127 int result; 128 CONST char *str1, *str2; 129 int len1, len2; 130 131 if (objc != 3) { 132 Tcl_WrongNumArgs(interp, 1, objv, "string1 string2"); 133 return TCL_ERROR; 134 } 135 136 str1 = Tcl_GetStringFromObj(objv[1], &len1); 137 str2 = Tcl_GetStringFromObj(objv[2], &len2); 138 if (len1 == len2) { 139 result = (Tcl_UtfNcmp(str1, str2, len1) == 0); 140 } else { 141 result = 0; 142 } 143 Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); 144 return TCL_OK; 145} 146 147/* 148 *---------------------------------------------------------------------- 149 * 150 * PkguaQuoteObjCmd -- 151 * 152 * This procedure is invoked to process the "pkgua_quote" Tcl command. It 153 * expects one argument, which it returns as result. 154 * 155 * Results: 156 * A standard Tcl result. 157 * 158 * Side effects: 159 * See the user documentation. 160 * 161 *---------------------------------------------------------------------- 162 */ 163 164static int 165PkguaQuoteObjCmd( 166 ClientData dummy, /* Not used. */ 167 Tcl_Interp *interp, /* Current interpreter. */ 168 int objc, /* Number of arguments. */ 169 Tcl_Obj *CONST objv[]) /* Argument strings. */ 170{ 171 if (objc != 2) { 172 Tcl_WrongNumArgs(interp, 1, objv, "value"); 173 return TCL_ERROR; 174 } 175 Tcl_SetObjResult(interp, objv[1]); 176 return TCL_OK; 177} 178 179/* 180 *---------------------------------------------------------------------- 181 * 182 * Pkgua_Init -- 183 * 184 * This is a package initialization procedure, which is called by Tcl 185 * when this package is to be added to an interpreter. 186 * 187 * Results: 188 * None. 189 * 190 * Side effects: 191 * None. 192 * 193 *---------------------------------------------------------------------- 194 */ 195 196int 197Pkgua_Init( 198 Tcl_Interp *interp) /* Interpreter in which the package is to be 199 * made available. */ 200{ 201 int code, cmdIndex = 0; 202 Tcl_Command *cmdTokens; 203 204 if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { 205 return TCL_ERROR; 206 } 207 208 /* 209 * Initialise our Hash table, where we store the registered command tokens 210 * for each interpreter. 211 */ 212 213 PkguaInitTokensHashTable(); 214 215 code = Tcl_PkgProvide(interp, "Pkgua", "1.0"); 216 if (code != TCL_OK) { 217 return code; 218 } 219 220 Tcl_SetVar(interp, "::pkgua_loaded", ".", TCL_APPEND_VALUE); 221 222 cmdTokens = PkguaInterpToTokens(interp); 223 cmdTokens[cmdIndex++] = 224 Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, 225 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 226 cmdTokens[cmdIndex++] = 227 Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, 228 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 229 return TCL_OK; 230} 231 232/* 233 *---------------------------------------------------------------------- 234 * 235 * Pkgua_SafeInit -- 236 * 237 * This is a package initialization procedure, which is called by Tcl 238 * when this package is to be added to a safe interpreter. 239 * 240 * Results: 241 * None. 242 * 243 * Side effects: 244 * None. 245 * 246 *---------------------------------------------------------------------- 247 */ 248 249int 250Pkgua_SafeInit( 251 Tcl_Interp *interp) /* Interpreter in which the package is to be 252 * made available. */ 253{ 254 return Pkgua_Init(interp); 255} 256 257/* 258 *---------------------------------------------------------------------- 259 * 260 * Pkgua_Unload -- 261 * 262 * This is a package unloading initialization procedure, which is called 263 * by Tcl when this package is to be unloaded from an interpreter. 264 * 265 * Results: 266 * None. 267 * 268 * Side effects: 269 * None. 270 * 271 *---------------------------------------------------------------------- 272 */ 273 274int 275Pkgua_Unload( 276 Tcl_Interp *interp, /* Interpreter from which the package is to be 277 * unloaded. */ 278 int flags) /* Flags passed by the unloading mechanism */ 279{ 280 int code, cmdIndex; 281 Tcl_Command *cmdTokens = PkguaInterpToTokens(interp); 282 283 for (cmdIndex=0 ; cmdIndex<MAX_REGISTERED_COMMANDS ; cmdIndex++) { 284 if (cmdTokens[cmdIndex] == NULL) { 285 continue; 286 } 287 code = Tcl_DeleteCommandFromToken(interp, cmdTokens[cmdIndex]); 288 if (code != TCL_OK) { 289 return code; 290 } 291 } 292 293 PkguaDeleteTokens(interp); 294 295 Tcl_SetVar(interp, "::pkgua_detached", ".", TCL_APPEND_VALUE); 296 297 if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) { 298 /* 299 * Tcl is ready to detach this library from the running application. 300 * We should free all the memory that is not related to any 301 * interpreter. 302 */ 303 304 PkguaFreeTokensHashTable(); 305 Tcl_SetVar(interp, "::pkgua_unloaded", ".", TCL_APPEND_VALUE); 306 } 307 return TCL_OK; 308} 309 310/* 311 *---------------------------------------------------------------------- 312 * 313 * Pkgua_SafeUnload -- 314 * 315 * This is a package unloading initialization procedure, which is called 316 * by Tcl when this package is to be unloaded from an interpreter. 317 * 318 * Results: 319 * None. 320 * 321 * Side effects: 322 * None. 323 * 324 *---------------------------------------------------------------------- 325 */ 326 327int 328Pkgua_SafeUnload( 329 Tcl_Interp *interp, /* Interpreter from which the package is to be 330 * unloaded. */ 331 int flags) /* Flags passed by the unloading mechanism */ 332{ 333 return Pkgua_Unload(interp, flags); 334} 335