util/src/TclTk/tcl8.6.12/unix/dltest/pkgua.c

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