os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLoad.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclLoad.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,701 @@
1.4 +/*
1.5 + * tclLoad.c --
1.6 + *
1.7 + * This file provides the generic portion (those that are the same
1.8 + * on all platforms) of Tcl's dynamic loading facilities.
1.9 + *
1.10 + * Copyright (c) 1995-1997 Sun Microsystems, Inc.
1.11 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.12 + *
1.13 + * See the file "license.terms" for information on usage and redistribution
1.14 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 + *
1.16 + * RCS: @(#) $Id: tclLoad.c,v 1.9 2003/02/01 23:37:29 kennykb Exp $
1.17 + */
1.18 +
1.19 +#include "tclInt.h"
1.20 +
1.21 +/*
1.22 + * The following structure describes a package that has been loaded
1.23 + * either dynamically (with the "load" command) or statically (as
1.24 + * indicated by a call to TclGetLoadedPackages). All such packages
1.25 + * are linked together into a single list for the process. Packages
1.26 + * are never unloaded, until the application exits, when
1.27 + * TclFinalizeLoad is called, and these structures are freed.
1.28 + */
1.29 +
1.30 +typedef struct LoadedPackage {
1.31 + char *fileName; /* Name of the file from which the
1.32 + * package was loaded. An empty string
1.33 + * means the package is loaded statically.
1.34 + * Malloc-ed. */
1.35 + char *packageName; /* Name of package prefix for the package,
1.36 + * properly capitalized (first letter UC,
1.37 + * others LC), no "_", as in "Net".
1.38 + * Malloc-ed. */
1.39 + Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be
1.40 + * passed to (*unLoadProcPtr)() when the file
1.41 + * is no longer needed. If fileName is NULL,
1.42 + * then this field is irrelevant. */
1.43 + Tcl_PackageInitProc *initProc;
1.44 + /* Initialization procedure to call to
1.45 + * incorporate this package into a trusted
1.46 + * interpreter. */
1.47 + Tcl_PackageInitProc *safeInitProc;
1.48 + /* Initialization procedure to call to
1.49 + * incorporate this package into a safe
1.50 + * interpreter (one that will execute
1.51 + * untrusted scripts). NULL means the
1.52 + * package can't be used in unsafe
1.53 + * interpreters. */
1.54 + Tcl_FSUnloadFileProc *unLoadProcPtr;
1.55 + /* Procedure to use to unload this package.
1.56 + * If NULL, then we do not attempt to unload
1.57 + * the package. If fileName is NULL, then
1.58 + * this field is irrelevant. */
1.59 + struct LoadedPackage *nextPtr;
1.60 + /* Next in list of all packages loaded into
1.61 + * this application process. NULL means
1.62 + * end of list. */
1.63 +} LoadedPackage;
1.64 +
1.65 +/*
1.66 + * TCL_THREADS
1.67 + * There is a global list of packages that is anchored at firstPackagePtr.
1.68 + * Access to this list is governed by a mutex.
1.69 + */
1.70 +
1.71 +static LoadedPackage *firstPackagePtr = NULL;
1.72 + /* First in list of all packages loaded into
1.73 + * this process. */
1.74 +
1.75 +TCL_DECLARE_MUTEX(packageMutex)
1.76 +
1.77 +/*
1.78 + * The following structure represents a particular package that has
1.79 + * been incorporated into a particular interpreter (by calling its
1.80 + * initialization procedure). There is a list of these structures for
1.81 + * each interpreter, with an AssocData value (key "load") for the
1.82 + * interpreter that points to the first package (if any).
1.83 + */
1.84 +
1.85 +typedef struct InterpPackage {
1.86 + LoadedPackage *pkgPtr; /* Points to detailed information about
1.87 + * package. */
1.88 + struct InterpPackage *nextPtr;
1.89 + /* Next package in this interpreter, or
1.90 + * NULL for end of list. */
1.91 +} InterpPackage;
1.92 +
1.93 +/*
1.94 + * Prototypes for procedures that are private to this file:
1.95 + */
1.96 +
1.97 +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
1.98 + Tcl_Interp *interp));
1.99 +
1.100 +/*
1.101 + *----------------------------------------------------------------------
1.102 + *
1.103 + * Tcl_LoadObjCmd --
1.104 + *
1.105 + * This procedure is invoked to process the "load" Tcl command.
1.106 + * See the user documentation for details on what it does.
1.107 + *
1.108 + * Results:
1.109 + * A standard Tcl result.
1.110 + *
1.111 + * Side effects:
1.112 + * See the user documentation.
1.113 + *
1.114 + *----------------------------------------------------------------------
1.115 + */
1.116 +
1.117 +int
1.118 +Tcl_LoadObjCmd(dummy, interp, objc, objv)
1.119 + ClientData dummy; /* Not used. */
1.120 + Tcl_Interp *interp; /* Current interpreter. */
1.121 + int objc; /* Number of arguments. */
1.122 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.123 +{
1.124 + Tcl_Interp *target;
1.125 + LoadedPackage *pkgPtr, *defaultPtr;
1.126 + Tcl_DString pkgName, tmp, initName, safeInitName;
1.127 + Tcl_PackageInitProc *initProc, *safeInitProc;
1.128 + InterpPackage *ipFirstPtr, *ipPtr;
1.129 + int code, namesMatch, filesMatch;
1.130 + char *p, *fullFileName, *packageName;
1.131 + Tcl_LoadHandle loadHandle;
1.132 + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
1.133 + Tcl_UniChar ch;
1.134 + int offset;
1.135 +
1.136 + if ((objc < 2) || (objc > 4)) {
1.137 + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
1.138 + return TCL_ERROR;
1.139 + }
1.140 + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
1.141 + return TCL_ERROR;
1.142 + }
1.143 + fullFileName = Tcl_GetString(objv[1]);
1.144 +
1.145 + Tcl_DStringInit(&pkgName);
1.146 + Tcl_DStringInit(&initName);
1.147 + Tcl_DStringInit(&safeInitName);
1.148 + Tcl_DStringInit(&tmp);
1.149 +
1.150 + packageName = NULL;
1.151 + if (objc >= 3) {
1.152 + packageName = Tcl_GetString(objv[2]);
1.153 + if (packageName[0] == '\0') {
1.154 + packageName = NULL;
1.155 + }
1.156 + }
1.157 + if ((fullFileName[0] == 0) && (packageName == NULL)) {
1.158 + Tcl_SetResult(interp,
1.159 + "must specify either file name or package name",
1.160 + TCL_STATIC);
1.161 + code = TCL_ERROR;
1.162 + goto done;
1.163 + }
1.164 +
1.165 + /*
1.166 + * Figure out which interpreter we're going to load the package into.
1.167 + */
1.168 +
1.169 + target = interp;
1.170 + if (objc == 4) {
1.171 + char *slaveIntName;
1.172 + slaveIntName = Tcl_GetString(objv[3]);
1.173 + target = Tcl_GetSlave(interp, slaveIntName);
1.174 + if (target == NULL) {
1.175 + return TCL_ERROR;
1.176 + }
1.177 + }
1.178 +
1.179 + /*
1.180 + * Scan through the packages that are currently loaded to see if the
1.181 + * package we want is already loaded. We'll use a loaded package if
1.182 + * it meets any of the following conditions:
1.183 + * - Its name and file match the once we're looking for.
1.184 + * - Its file matches, and we weren't given a name.
1.185 + * - Its name matches, the file name was specified as empty, and there
1.186 + * is only no statically loaded package with the same name.
1.187 + */
1.188 + Tcl_MutexLock(&packageMutex);
1.189 +
1.190 + defaultPtr = NULL;
1.191 + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
1.192 + if (packageName == NULL) {
1.193 + namesMatch = 0;
1.194 + } else {
1.195 + Tcl_DStringSetLength(&pkgName, 0);
1.196 + Tcl_DStringAppend(&pkgName, packageName, -1);
1.197 + Tcl_DStringSetLength(&tmp, 0);
1.198 + Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
1.199 + Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
1.200 + Tcl_UtfToLower(Tcl_DStringValue(&tmp));
1.201 + if (strcmp(Tcl_DStringValue(&tmp),
1.202 + Tcl_DStringValue(&pkgName)) == 0) {
1.203 + namesMatch = 1;
1.204 + } else {
1.205 + namesMatch = 0;
1.206 + }
1.207 + }
1.208 + Tcl_DStringSetLength(&pkgName, 0);
1.209 +
1.210 + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
1.211 + if (filesMatch && (namesMatch || (packageName == NULL))) {
1.212 + break;
1.213 + }
1.214 + if (namesMatch && (fullFileName[0] == 0)) {
1.215 + defaultPtr = pkgPtr;
1.216 + }
1.217 + if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
1.218 + /*
1.219 + * Can't have two different packages loaded from the same
1.220 + * file.
1.221 + */
1.222 +
1.223 + Tcl_AppendResult(interp, "file \"", fullFileName,
1.224 + "\" is already loaded for package \"",
1.225 + pkgPtr->packageName, "\"", (char *) NULL);
1.226 + code = TCL_ERROR;
1.227 + Tcl_MutexUnlock(&packageMutex);
1.228 + goto done;
1.229 + }
1.230 + }
1.231 + Tcl_MutexUnlock(&packageMutex);
1.232 + if (pkgPtr == NULL) {
1.233 + pkgPtr = defaultPtr;
1.234 + }
1.235 +
1.236 + /*
1.237 + * Scan through the list of packages already loaded in the target
1.238 + * interpreter. If the package we want is already loaded there,
1.239 + * then there's nothing for us to to.
1.240 + */
1.241 +
1.242 + if (pkgPtr != NULL) {
1.243 + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
1.244 + (Tcl_InterpDeleteProc **) NULL);
1.245 + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
1.246 + if (ipPtr->pkgPtr == pkgPtr) {
1.247 + code = TCL_OK;
1.248 + goto done;
1.249 + }
1.250 + }
1.251 + }
1.252 +
1.253 + if (pkgPtr == NULL) {
1.254 + /*
1.255 + * The desired file isn't currently loaded, so load it. It's an
1.256 + * error if the desired package is a static one.
1.257 + */
1.258 +
1.259 + if (fullFileName[0] == 0) {
1.260 + Tcl_AppendResult(interp, "package \"", packageName,
1.261 + "\" isn't loaded statically", (char *) NULL);
1.262 + code = TCL_ERROR;
1.263 + goto done;
1.264 + }
1.265 +
1.266 + /*
1.267 + * Figure out the module name if it wasn't provided explicitly.
1.268 + */
1.269 +
1.270 + if (packageName != NULL) {
1.271 + Tcl_DStringAppend(&pkgName, packageName, -1);
1.272 + } else {
1.273 + int retc;
1.274 + /*
1.275 + * Threading note - this call used to be protected by a mutex.
1.276 + */
1.277 + retc = TclGuessPackageName(fullFileName, &pkgName);
1.278 + if (!retc) {
1.279 + Tcl_Obj *splitPtr;
1.280 + Tcl_Obj *pkgGuessPtr;
1.281 + int pElements;
1.282 + char *pkgGuess;
1.283 +
1.284 + /*
1.285 + * The platform-specific code couldn't figure out the
1.286 + * module name. Make a guess by taking the last element
1.287 + * of the file name, stripping off any leading "lib",
1.288 + * and then using all of the alphabetic and underline
1.289 + * characters that follow that.
1.290 + */
1.291 +
1.292 + splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
1.293 + Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
1.294 + pkgGuess = Tcl_GetString(pkgGuessPtr);
1.295 + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
1.296 + && (pkgGuess[2] == 'b')) {
1.297 + pkgGuess += 3;
1.298 + }
1.299 + for (p = pkgGuess; *p != 0; p += offset) {
1.300 + offset = Tcl_UtfToUniChar(p, &ch);
1.301 + if ((ch > 0x100)
1.302 + || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
1.303 + || (UCHAR(ch) == '_'))) {
1.304 + break;
1.305 + }
1.306 + }
1.307 + if (p == pkgGuess) {
1.308 + Tcl_DecrRefCount(splitPtr);
1.309 + Tcl_AppendResult(interp,
1.310 + "couldn't figure out package name for ",
1.311 + fullFileName, (char *) NULL);
1.312 + code = TCL_ERROR;
1.313 + goto done;
1.314 + }
1.315 + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
1.316 + Tcl_DecrRefCount(splitPtr);
1.317 + }
1.318 + }
1.319 +
1.320 + /*
1.321 + * Fix the capitalization in the package name so that the first
1.322 + * character is in caps (or title case) but the others are all
1.323 + * lower-case.
1.324 + */
1.325 +
1.326 + Tcl_DStringSetLength(&pkgName,
1.327 + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
1.328 +
1.329 + /*
1.330 + * Compute the names of the two initialization procedures,
1.331 + * based on the package name.
1.332 + */
1.333 +
1.334 + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
1.335 + Tcl_DStringAppend(&initName, "_Init", 5);
1.336 + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
1.337 + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
1.338 +
1.339 + /*
1.340 + * Call platform-specific code to load the package and find the
1.341 + * two initialization procedures.
1.342 + */
1.343 +
1.344 + Tcl_MutexLock(&packageMutex);
1.345 + code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
1.346 + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
1.347 + &loadHandle,&unLoadProcPtr);
1.348 + Tcl_MutexUnlock(&packageMutex);
1.349 + if (code != TCL_OK) {
1.350 + goto done;
1.351 + }
1.352 + if (initProc == NULL) {
1.353 + Tcl_AppendResult(interp, "couldn't find procedure ",
1.354 + Tcl_DStringValue(&initName), (char *) NULL);
1.355 + if (unLoadProcPtr != NULL) {
1.356 + (*unLoadProcPtr)(loadHandle);
1.357 + }
1.358 + code = TCL_ERROR;
1.359 + goto done;
1.360 + }
1.361 +
1.362 + /*
1.363 + * Create a new record to describe this package.
1.364 + */
1.365 +
1.366 + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
1.367 + pkgPtr->fileName = (char *) ckalloc((unsigned)
1.368 + (strlen(fullFileName) + 1));
1.369 + strcpy(pkgPtr->fileName, fullFileName);
1.370 + pkgPtr->packageName = (char *) ckalloc((unsigned)
1.371 + (Tcl_DStringLength(&pkgName) + 1));
1.372 + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
1.373 + pkgPtr->loadHandle = loadHandle;
1.374 + pkgPtr->unLoadProcPtr = unLoadProcPtr;
1.375 + pkgPtr->initProc = initProc;
1.376 + pkgPtr->safeInitProc = safeInitProc;
1.377 + Tcl_MutexLock(&packageMutex);
1.378 + pkgPtr->nextPtr = firstPackagePtr;
1.379 + firstPackagePtr = pkgPtr;
1.380 + Tcl_MutexUnlock(&packageMutex);
1.381 + }
1.382 +
1.383 + /*
1.384 + * Invoke the package's initialization procedure (either the
1.385 + * normal one or the safe one, depending on whether or not the
1.386 + * interpreter is safe).
1.387 + */
1.388 +
1.389 + if (Tcl_IsSafe(target)) {
1.390 + if (pkgPtr->safeInitProc != NULL) {
1.391 + code = (*pkgPtr->safeInitProc)(target);
1.392 + } else {
1.393 + Tcl_AppendResult(interp,
1.394 + "can't use package in a safe interpreter: ",
1.395 + "no ", pkgPtr->packageName, "_SafeInit procedure",
1.396 + (char *) NULL);
1.397 + code = TCL_ERROR;
1.398 + goto done;
1.399 + }
1.400 + } else {
1.401 + code = (*pkgPtr->initProc)(target);
1.402 + }
1.403 +
1.404 + /*
1.405 + * Record the fact that the package has been loaded in the
1.406 + * target interpreter.
1.407 + */
1.408 +
1.409 + if (code == TCL_OK) {
1.410 + /*
1.411 + * Refetch ipFirstPtr: loading the package may have introduced
1.412 + * additional static packages at the head of the linked list!
1.413 + */
1.414 +
1.415 + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
1.416 + (Tcl_InterpDeleteProc **) NULL);
1.417 + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
1.418 + ipPtr->pkgPtr = pkgPtr;
1.419 + ipPtr->nextPtr = ipFirstPtr;
1.420 + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
1.421 + (ClientData) ipPtr);
1.422 + } else {
1.423 + TclTransferResult(target, code, interp);
1.424 + }
1.425 +
1.426 + done:
1.427 + Tcl_DStringFree(&pkgName);
1.428 + Tcl_DStringFree(&initName);
1.429 + Tcl_DStringFree(&safeInitName);
1.430 + Tcl_DStringFree(&tmp);
1.431 + return code;
1.432 +}
1.433 +
1.434 +/*
1.435 + *----------------------------------------------------------------------
1.436 + *
1.437 + * Tcl_StaticPackage --
1.438 + *
1.439 + * This procedure is invoked to indicate that a particular
1.440 + * package has been linked statically with an application.
1.441 + *
1.442 + * Results:
1.443 + * None.
1.444 + *
1.445 + * Side effects:
1.446 + * Once this procedure completes, the package becomes loadable
1.447 + * via the "load" command with an empty file name.
1.448 + *
1.449 + *----------------------------------------------------------------------
1.450 + */
1.451 +
1.452 +EXPORT_C void
1.453 +Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
1.454 + Tcl_Interp *interp; /* If not NULL, it means that the
1.455 + * package has already been loaded
1.456 + * into the given interpreter by
1.457 + * calling the appropriate init proc. */
1.458 + CONST char *pkgName; /* Name of package (must be properly
1.459 + * capitalized: first letter upper
1.460 + * case, others lower case). */
1.461 + Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate
1.462 + * this package into a trusted
1.463 + * interpreter. */
1.464 + Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate
1.465 + * this package into a safe interpreter
1.466 + * (one that will execute untrusted
1.467 + * scripts). NULL means the package
1.468 + * can't be used in safe
1.469 + * interpreters. */
1.470 +{
1.471 + LoadedPackage *pkgPtr;
1.472 + InterpPackage *ipPtr, *ipFirstPtr;
1.473 +
1.474 + /*
1.475 + * Check to see if someone else has already reported this package as
1.476 + * statically loaded in the process.
1.477 + */
1.478 +
1.479 + Tcl_MutexLock(&packageMutex);
1.480 + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
1.481 + if ((pkgPtr->initProc == initProc)
1.482 + && (pkgPtr->safeInitProc == safeInitProc)
1.483 + && (strcmp(pkgPtr->packageName, pkgName) == 0)) {
1.484 + break;
1.485 + }
1.486 + }
1.487 + Tcl_MutexUnlock(&packageMutex);
1.488 +
1.489 + /*
1.490 + * If the package is not yet recorded as being loaded statically,
1.491 + * add it to the list now.
1.492 + */
1.493 +
1.494 + if ( pkgPtr == NULL ) {
1.495 + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
1.496 + pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
1.497 + pkgPtr->fileName[0] = 0;
1.498 + pkgPtr->packageName = (char *) ckalloc((unsigned)
1.499 + (strlen(pkgName) + 1));
1.500 + strcpy(pkgPtr->packageName, pkgName);
1.501 + pkgPtr->loadHandle = NULL;
1.502 + pkgPtr->initProc = initProc;
1.503 + pkgPtr->safeInitProc = safeInitProc;
1.504 + Tcl_MutexLock(&packageMutex);
1.505 + pkgPtr->nextPtr = firstPackagePtr;
1.506 + firstPackagePtr = pkgPtr;
1.507 + Tcl_MutexUnlock(&packageMutex);
1.508 + }
1.509 +
1.510 + if (interp != NULL) {
1.511 +
1.512 + /*
1.513 + * If we're loading the package into an interpreter,
1.514 + * determine whether it's already loaded.
1.515 + */
1.516 +
1.517 + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
1.518 + (Tcl_InterpDeleteProc **) NULL);
1.519 + for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
1.520 + if ( ipPtr->pkgPtr == pkgPtr ) {
1.521 + return;
1.522 + }
1.523 + }
1.524 +
1.525 + /*
1.526 + * Package isn't loade in the current interp yet. Mark it as
1.527 + * now being loaded.
1.528 + */
1.529 +
1.530 + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
1.531 + ipPtr->pkgPtr = pkgPtr;
1.532 + ipPtr->nextPtr = ipFirstPtr;
1.533 + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
1.534 + (ClientData) ipPtr);
1.535 + }
1.536 +}
1.537 +
1.538 +/*
1.539 + *----------------------------------------------------------------------
1.540 + *
1.541 + * TclGetLoadedPackages --
1.542 + *
1.543 + * This procedure returns information about all of the files
1.544 + * that are loaded (either in a particular intepreter, or
1.545 + * for all interpreters).
1.546 + *
1.547 + * Results:
1.548 + * The return value is a standard Tcl completion code. If
1.549 + * successful, a list of lists is placed in the interp's result.
1.550 + * Each sublist corresponds to one loaded file; its first
1.551 + * element is the name of the file (or an empty string for
1.552 + * something that's statically loaded) and the second element
1.553 + * is the name of the package in that file.
1.554 + *
1.555 + * Side effects:
1.556 + * None.
1.557 + *
1.558 + *----------------------------------------------------------------------
1.559 + */
1.560 +
1.561 +int
1.562 +TclGetLoadedPackages(interp, targetName)
1.563 + Tcl_Interp *interp; /* Interpreter in which to return
1.564 + * information or error message. */
1.565 + char *targetName; /* Name of target interpreter or NULL.
1.566 + * If NULL, return info about all interps;
1.567 + * otherwise, just return info about this
1.568 + * interpreter. */
1.569 +{
1.570 + Tcl_Interp *target;
1.571 + LoadedPackage *pkgPtr;
1.572 + InterpPackage *ipPtr;
1.573 + char *prefix;
1.574 +
1.575 + if (targetName == NULL) {
1.576 + /*
1.577 + * Return information about all of the available packages.
1.578 + */
1.579 +
1.580 + prefix = "{";
1.581 + Tcl_MutexLock(&packageMutex);
1.582 + for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
1.583 + pkgPtr = pkgPtr->nextPtr) {
1.584 + Tcl_AppendResult(interp, prefix, (char *) NULL);
1.585 + Tcl_AppendElement(interp, pkgPtr->fileName);
1.586 + Tcl_AppendElement(interp, pkgPtr->packageName);
1.587 + Tcl_AppendResult(interp, "}", (char *) NULL);
1.588 + prefix = " {";
1.589 + }
1.590 + Tcl_MutexUnlock(&packageMutex);
1.591 + return TCL_OK;
1.592 + }
1.593 +
1.594 + /*
1.595 + * Return information about only the packages that are loaded in
1.596 + * a given interpreter.
1.597 + */
1.598 +
1.599 + target = Tcl_GetSlave(interp, targetName);
1.600 + if (target == NULL) {
1.601 + return TCL_ERROR;
1.602 + }
1.603 + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
1.604 + (Tcl_InterpDeleteProc **) NULL);
1.605 + prefix = "{";
1.606 + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
1.607 + pkgPtr = ipPtr->pkgPtr;
1.608 + Tcl_AppendResult(interp, prefix, (char *) NULL);
1.609 + Tcl_AppendElement(interp, pkgPtr->fileName);
1.610 + Tcl_AppendElement(interp, pkgPtr->packageName);
1.611 + Tcl_AppendResult(interp, "}", (char *) NULL);
1.612 + prefix = " {";
1.613 + }
1.614 + return TCL_OK;
1.615 +}
1.616 +
1.617 +/*
1.618 + *----------------------------------------------------------------------
1.619 + *
1.620 + * LoadCleanupProc --
1.621 + *
1.622 + * This procedure is called to delete all of the InterpPackage
1.623 + * structures for an interpreter when the interpreter is deleted.
1.624 + * It gets invoked via the Tcl AssocData mechanism.
1.625 + *
1.626 + * Results:
1.627 + * None.
1.628 + *
1.629 + * Side effects:
1.630 + * Storage for all of the InterpPackage procedures for interp
1.631 + * get deleted.
1.632 + *
1.633 + *----------------------------------------------------------------------
1.634 + */
1.635 +
1.636 +static void
1.637 +LoadCleanupProc(clientData, interp)
1.638 + ClientData clientData; /* Pointer to first InterpPackage structure
1.639 + * for interp. */
1.640 + Tcl_Interp *interp; /* Interpreter that is being deleted. */
1.641 +{
1.642 + InterpPackage *ipPtr, *nextPtr;
1.643 +
1.644 + ipPtr = (InterpPackage *) clientData;
1.645 + while (ipPtr != NULL) {
1.646 + nextPtr = ipPtr->nextPtr;
1.647 + ckfree((char *) ipPtr);
1.648 + ipPtr = nextPtr;
1.649 + }
1.650 +}
1.651 +
1.652 +/*
1.653 + *----------------------------------------------------------------------
1.654 + *
1.655 + * TclFinalizeLoad --
1.656 + *
1.657 + * This procedure is invoked just before the application exits.
1.658 + * It frees all of the LoadedPackage structures.
1.659 + *
1.660 + * Results:
1.661 + * None.
1.662 + *
1.663 + * Side effects:
1.664 + * Memory is freed.
1.665 + *
1.666 + *----------------------------------------------------------------------
1.667 + */
1.668 +
1.669 +void
1.670 +TclFinalizeLoad()
1.671 +{
1.672 + LoadedPackage *pkgPtr;
1.673 +
1.674 + /*
1.675 + * No synchronization here because there should just be
1.676 + * one thread alive at this point. Logically,
1.677 + * packageMutex should be grabbed at this point, but
1.678 + * the Mutexes get finalized before the call to this routine.
1.679 + * The only subsystem left alive at this point is the
1.680 + * memory allocator.
1.681 + */
1.682 +
1.683 + while (firstPackagePtr != NULL) {
1.684 + pkgPtr = firstPackagePtr;
1.685 + firstPackagePtr = pkgPtr->nextPtr;
1.686 +#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
1.687 + /*
1.688 + * Some Unix dlls are poorly behaved - registering things like
1.689 + * atexit calls that can't be unregistered. If you unload
1.690 + * such dlls, you get a core on exit because it wants to
1.691 + * call a function in the dll after it's been unloaded.
1.692 + */
1.693 + if (pkgPtr->fileName[0] != '\0') {
1.694 + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
1.695 + if (unLoadProcPtr != NULL) {
1.696 + (*unLoadProcPtr)(pkgPtr->loadHandle);
1.697 + }
1.698 + }
1.699 +#endif
1.700 + ckfree(pkgPtr->fileName);
1.701 + ckfree(pkgPtr->packageName);
1.702 + ckfree((char *) pkgPtr);
1.703 + }
1.704 +}