1/* 2 * tclLoad.c -- 3 * 4 * This file provides the generic portion (those that are the same on all 5 * platforms) of Tcl's dynamic loading facilities. 6 * 7 * Copyright (c) 1995-1997 Sun Microsystems, Inc. 8 * 9 * See the file "license.terms" for information on usage and redistribution of 10 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 * 12 * RCS: @(#) $Id: tclLoad.c,v 1.16.4.2 2008/11/14 00:22:39 nijtmans Exp $ 13 */ 14 15#include "tclInt.h" 16 17/* 18 * The following structure describes a package that has been loaded either 19 * dynamically (with the "load" command) or statically (as indicated by a call 20 * to TclGetLoadedPackages). All such packages are linked together into a 21 * single list for the process. Packages are never unloaded, until the 22 * application exits, when TclFinalizeLoad is called, and these structures are 23 * freed. 24 */ 25 26typedef struct LoadedPackage { 27 char *fileName; /* Name of the file from which the package was 28 * loaded. An empty string means the package 29 * is loaded statically. Malloc-ed. */ 30 char *packageName; /* Name of package prefix for the package, 31 * properly capitalized (first letter UC, 32 * others LC), no "_", as in "Net". 33 * Malloc-ed. */ 34 Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be 35 * passed to (*unLoadProcPtr)() when the file 36 * is no longer needed. If fileName is NULL, 37 * then this field is irrelevant. */ 38 Tcl_PackageInitProc *initProc; 39 /* Initialization function to call to 40 * incorporate this package into a trusted 41 * interpreter. */ 42 Tcl_PackageInitProc *safeInitProc; 43 /* Initialization function to call to 44 * incorporate this package into a safe 45 * interpreter (one that will execute 46 * untrusted scripts). NULL means the package 47 * can't be used in unsafe interpreters. */ 48 Tcl_PackageUnloadProc *unloadProc; 49 /* Finalisation function to unload a package 50 * from a trusted interpreter. NULL means that 51 * the package cannot be unloaded. */ 52 Tcl_PackageUnloadProc *safeUnloadProc; 53 /* Finalisation function to unload a package 54 * from a safe interpreter. NULL means that 55 * the package cannot be unloaded. */ 56 int interpRefCount; /* How many times the package has been loaded 57 * in trusted interpreters. */ 58 int safeInterpRefCount; /* How many times the package has been loaded 59 * in safe interpreters. */ 60 Tcl_FSUnloadFileProc *unLoadProcPtr; 61 /* Function to use to unload this package. If 62 * NULL, then we do not attempt to unload the 63 * package. If fileName is NULL, then this 64 * field is irrelevant. */ 65 struct LoadedPackage *nextPtr; 66 /* Next in list of all packages loaded into 67 * this application process. NULL means end of 68 * list. */ 69} LoadedPackage; 70 71/* 72 * TCL_THREADS 73 * There is a global list of packages that is anchored at firstPackagePtr. 74 * Access to this list is governed by a mutex. 75 */ 76 77static LoadedPackage *firstPackagePtr = NULL; 78 /* First in list of all packages loaded into 79 * this process. */ 80 81TCL_DECLARE_MUTEX(packageMutex) 82 83/* 84 * The following structure represents a particular package that has been 85 * incorporated into a particular interpreter (by calling its initialization 86 * function). There is a list of these structures for each interpreter, with 87 * an AssocData value (key "load") for the interpreter that points to the 88 * first package (if any). 89 */ 90 91typedef struct InterpPackage { 92 LoadedPackage *pkgPtr; /* Points to detailed information about 93 * package. */ 94 struct InterpPackage *nextPtr; 95 /* Next package in this interpreter, or NULL 96 * for end of list. */ 97} InterpPackage; 98 99/* 100 * Prototypes for functions that are private to this file: 101 */ 102 103static void LoadCleanupProc(ClientData clientData, 104 Tcl_Interp *interp); 105 106/* 107 *---------------------------------------------------------------------- 108 * 109 * Tcl_LoadObjCmd -- 110 * 111 * This function is invoked to process the "load" Tcl command. See the 112 * user documentation for details on what it does. 113 * 114 * Results: 115 * A standard Tcl result. 116 * 117 * Side effects: 118 * See the user documentation. 119 * 120 *---------------------------------------------------------------------- 121 */ 122 123int 124Tcl_LoadObjCmd( 125 ClientData dummy, /* Not used. */ 126 Tcl_Interp *interp, /* Current interpreter. */ 127 int objc, /* Number of arguments. */ 128 Tcl_Obj *const objv[]) /* Argument objects. */ 129{ 130 Tcl_Interp *target; 131 LoadedPackage *pkgPtr, *defaultPtr; 132 Tcl_DString pkgName, tmp, initName, safeInitName; 133 Tcl_DString unloadName, safeUnloadName; 134 Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; 135 InterpPackage *ipFirstPtr, *ipPtr; 136 int code, namesMatch, filesMatch, offset; 137 const char *symbols[4]; 138 Tcl_PackageInitProc **procPtrs[4]; 139 ClientData clientData; 140 char *p, *fullFileName, *packageName; 141 Tcl_LoadHandle loadHandle; 142 Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; 143 Tcl_UniChar ch; 144 145 if ((objc < 2) || (objc > 4)) { 146 Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); 147 return TCL_ERROR; 148 } 149 if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { 150 return TCL_ERROR; 151 } 152 fullFileName = Tcl_GetString(objv[1]); 153 154 Tcl_DStringInit(&pkgName); 155 Tcl_DStringInit(&initName); 156 Tcl_DStringInit(&safeInitName); 157 Tcl_DStringInit(&unloadName); 158 Tcl_DStringInit(&safeUnloadName); 159 Tcl_DStringInit(&tmp); 160 161 packageName = NULL; 162 if (objc >= 3) { 163 packageName = Tcl_GetString(objv[2]); 164 if (packageName[0] == '\0') { 165 packageName = NULL; 166 } 167 } 168 if ((fullFileName[0] == 0) && (packageName == NULL)) { 169 Tcl_SetResult(interp, 170 "must specify either file name or package name", 171 TCL_STATIC); 172 code = TCL_ERROR; 173 goto done; 174 } 175 176 /* 177 * Figure out which interpreter we're going to load the package into. 178 */ 179 180 target = interp; 181 if (objc == 4) { 182 char *slaveIntName = Tcl_GetString(objv[3]); 183 184 target = Tcl_GetSlave(interp, slaveIntName); 185 if (target == NULL) { 186 code = TCL_ERROR; 187 goto done; 188 } 189 } 190 191 /* 192 * Scan through the packages that are currently loaded to see if the 193 * package we want is already loaded. We'll use a loaded package if it 194 * meets any of the following conditions: 195 * - Its name and file match the once we're looking for. 196 * - Its file matches, and we weren't given a name. 197 * - Its name matches, the file name was specified as empty, and there is 198 * only no statically loaded package with the same name. 199 */ 200 201 Tcl_MutexLock(&packageMutex); 202 203 defaultPtr = NULL; 204 for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { 205 if (packageName == NULL) { 206 namesMatch = 0; 207 } else { 208 Tcl_DStringSetLength(&pkgName, 0); 209 Tcl_DStringAppend(&pkgName, packageName, -1); 210 Tcl_DStringSetLength(&tmp, 0); 211 Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); 212 Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); 213 Tcl_UtfToLower(Tcl_DStringValue(&tmp)); 214 if (strcmp(Tcl_DStringValue(&tmp), 215 Tcl_DStringValue(&pkgName)) == 0) { 216 namesMatch = 1; 217 } else { 218 namesMatch = 0; 219 } 220 } 221 Tcl_DStringSetLength(&pkgName, 0); 222 223 filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); 224 if (filesMatch && (namesMatch || (packageName == NULL))) { 225 break; 226 } 227 if (namesMatch && (fullFileName[0] == 0)) { 228 defaultPtr = pkgPtr; 229 } 230 if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { 231 /* 232 * Can't have two different packages loaded from the same file. 233 */ 234 235 Tcl_AppendResult(interp, "file \"", fullFileName, 236 "\" is already loaded for package \"", 237 pkgPtr->packageName, "\"", NULL); 238 code = TCL_ERROR; 239 Tcl_MutexUnlock(&packageMutex); 240 goto done; 241 } 242 } 243 Tcl_MutexUnlock(&packageMutex); 244 if (pkgPtr == NULL) { 245 pkgPtr = defaultPtr; 246 } 247 248 /* 249 * Scan through the list of packages already loaded in the target 250 * interpreter. If the package we want is already loaded there, then 251 * there's nothing for us to do. 252 */ 253 254 if (pkgPtr != NULL) { 255 ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, 256 "tclLoad", NULL); 257 for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { 258 if (ipPtr->pkgPtr == pkgPtr) { 259 code = TCL_OK; 260 goto done; 261 } 262 } 263 } 264 265 if (pkgPtr == NULL) { 266 /* 267 * The desired file isn't currently loaded, so load it. It's an error 268 * if the desired package is a static one. 269 */ 270 271 if (fullFileName[0] == 0) { 272 Tcl_AppendResult(interp, "package \"", packageName, 273 "\" isn't loaded statically", NULL); 274 code = TCL_ERROR; 275 goto done; 276 } 277 278 /* 279 * Figure out the module name if it wasn't provided explicitly. 280 */ 281 282 if (packageName != NULL) { 283 Tcl_DStringAppend(&pkgName, packageName, -1); 284 } else { 285 int retc; 286 287 /* 288 * Threading note - this call used to be protected by a mutex. 289 */ 290 291 retc = TclGuessPackageName(fullFileName, &pkgName); 292 if (!retc) { 293 Tcl_Obj *splitPtr; 294 Tcl_Obj *pkgGuessPtr; 295 int pElements; 296 char *pkgGuess; 297 298 /* 299 * The platform-specific code couldn't figure out the module 300 * name. Make a guess by taking the last element of the file 301 * name, stripping off any leading "lib", and then using all 302 * of the alphabetic and underline characters that follow 303 * that. 304 */ 305 306 splitPtr = Tcl_FSSplitPath(objv[1], &pElements); 307 Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); 308 pkgGuess = Tcl_GetString(pkgGuessPtr); 309 if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') 310 && (pkgGuess[2] == 'b')) { 311 pkgGuess += 3; 312 } 313 for (p = pkgGuess; *p != 0; p += offset) { 314 offset = Tcl_UtfToUniChar(p, &ch); 315 if ((ch > 0x100) 316 || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ 317 || (UCHAR(ch) == '_'))) { 318 break; 319 } 320 } 321 if (p == pkgGuess) { 322 Tcl_DecrRefCount(splitPtr); 323 Tcl_AppendResult(interp, 324 "couldn't figure out package name for ", 325 fullFileName, NULL); 326 code = TCL_ERROR; 327 goto done; 328 } 329 Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); 330 Tcl_DecrRefCount(splitPtr); 331 } 332 } 333 334 /* 335 * Fix the capitalization in the package name so that the first 336 * character is in caps (or title case) but the others are all 337 * lower-case. 338 */ 339 340 Tcl_DStringSetLength(&pkgName, 341 Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); 342 343 /* 344 * Compute the names of the two initialization functions, based on the 345 * package name. 346 */ 347 348 Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); 349 Tcl_DStringAppend(&initName, "_Init", 5); 350 Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); 351 Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); 352 Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); 353 Tcl_DStringAppend(&unloadName, "_Unload", 7); 354 Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); 355 Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); 356 357 /* 358 * Call platform-specific code to load the package and find the two 359 * initialization functions. 360 */ 361 362 symbols[0] = Tcl_DStringValue(&initName); 363 symbols[1] = Tcl_DStringValue(&safeInitName); 364 symbols[2] = Tcl_DStringValue(&unloadName); 365 symbols[3] = Tcl_DStringValue(&safeUnloadName); 366 procPtrs[0] = &initProc; 367 procPtrs[1] = &safeInitProc; 368 procPtrs[2] = &unloadProc; 369 procPtrs[3] = &safeUnloadProc; 370 371 Tcl_MutexLock(&packageMutex); 372 code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, 373 &loadHandle, &clientData, &unLoadProcPtr); 374 Tcl_MutexUnlock(&packageMutex); 375 loadHandle = (Tcl_LoadHandle) clientData; 376 if (code != TCL_OK) { 377 goto done; 378 } 379 380 if (*procPtrs[0] /* initProc */ == NULL) { 381 Tcl_AppendResult(interp, "couldn't find procedure ", 382 Tcl_DStringValue(&initName), NULL); 383 if (unLoadProcPtr != NULL) { 384 (*unLoadProcPtr)(loadHandle); 385 } 386 code = TCL_ERROR; 387 goto done; 388 } 389 390 /* 391 * Create a new record to describe this package. 392 */ 393 394 pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); 395 pkgPtr->fileName = (char *) ckalloc((unsigned) 396 (strlen(fullFileName) + 1)); 397 strcpy(pkgPtr->fileName, fullFileName); 398 pkgPtr->packageName = (char *) ckalloc((unsigned) 399 (Tcl_DStringLength(&pkgName) + 1)); 400 strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); 401 pkgPtr->loadHandle = loadHandle; 402 pkgPtr->unLoadProcPtr = unLoadProcPtr; 403 pkgPtr->initProc = *procPtrs[0]; 404 pkgPtr->safeInitProc = *procPtrs[1]; 405 pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; 406 pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; 407 pkgPtr->interpRefCount = 0; 408 pkgPtr->safeInterpRefCount = 0; 409 410 Tcl_MutexLock(&packageMutex); 411 pkgPtr->nextPtr = firstPackagePtr; 412 firstPackagePtr = pkgPtr; 413 Tcl_MutexUnlock(&packageMutex); 414 } 415 416 /* 417 * Invoke the package's initialization function (either the normal one or 418 * the safe one, depending on whether or not the interpreter is safe). 419 */ 420 421 if (Tcl_IsSafe(target)) { 422 if (pkgPtr->safeInitProc != NULL) { 423 code = (*pkgPtr->safeInitProc)(target); 424 } else { 425 Tcl_AppendResult(interp, 426 "can't use package in a safe interpreter: no ", 427 pkgPtr->packageName, "_SafeInit procedure", NULL); 428 code = TCL_ERROR; 429 goto done; 430 } 431 } else { 432 code = (*pkgPtr->initProc)(target); 433 } 434 435 /* 436 * Record the fact that the package has been loaded in the target 437 * interpreter. 438 */ 439 440 if (code == TCL_OK) { 441 /* 442 * Update the proper reference count. 443 */ 444 445 Tcl_MutexLock(&packageMutex); 446 if (Tcl_IsSafe(target)) { 447 ++pkgPtr->safeInterpRefCount; 448 } else { 449 ++pkgPtr->interpRefCount; 450 } 451 Tcl_MutexUnlock(&packageMutex); 452 453 /* 454 * Refetch ipFirstPtr: loading the package may have introduced 455 * additional static packages at the head of the linked list! 456 */ 457 458 ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, 459 "tclLoad", NULL); 460 ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); 461 ipPtr->pkgPtr = pkgPtr; 462 ipPtr->nextPtr = ipFirstPtr; 463 Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, 464 (ClientData) ipPtr); 465 } else { 466 TclTransferResult(target, code, interp); 467 } 468 469 done: 470 Tcl_DStringFree(&pkgName); 471 Tcl_DStringFree(&initName); 472 Tcl_DStringFree(&safeInitName); 473 Tcl_DStringFree(&unloadName); 474 Tcl_DStringFree(&safeUnloadName); 475 Tcl_DStringFree(&tmp); 476 return code; 477} 478 479/* 480 *---------------------------------------------------------------------- 481 * 482 * Tcl_UnloadObjCmd -- 483 * 484 * This function is invoked to process the "unload" Tcl command. See the 485 * user documentation for details on what it does. 486 * 487 * Results: 488 * A standard Tcl result. 489 * 490 * Side effects: 491 * See the user documentation. 492 * 493 *---------------------------------------------------------------------- 494 */ 495 496int 497Tcl_UnloadObjCmd( 498 ClientData dummy, /* Not used. */ 499 Tcl_Interp *interp, /* Current interpreter. */ 500 int objc, /* Number of arguments. */ 501 Tcl_Obj *const objv[]) /* Argument objects. */ 502{ 503 Tcl_Interp *target; /* Which interpreter to unload from. */ 504 LoadedPackage *pkgPtr, *defaultPtr; 505 Tcl_DString pkgName, tmp; 506 Tcl_PackageUnloadProc *unloadProc; 507 InterpPackage *ipFirstPtr, *ipPtr; 508 int i, index, code, complain = 1, keepLibrary = 0; 509 int trustedRefCount = -1, safeRefCount = -1; 510 const char *fullFileName = ""; 511 char *packageName; 512 static const char *options[] = { 513 "-nocomplain", "-keeplibrary", "--", NULL 514 }; 515 enum options { 516 UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST 517 }; 518 519 for (i = 1; i < objc; i++) { 520 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 521 &index) != TCL_OK) { 522 fullFileName = Tcl_GetString(objv[i]); 523 if (fullFileName[0] == '-') { 524 /* 525 * It looks like the command contains an option so signal an 526 * error 527 */ 528 529 return TCL_ERROR; 530 } else { 531 /* 532 * This clearly isn't an option; assume it's the filename. We 533 * must clear the error. 534 */ 535 536 Tcl_ResetResult(interp); 537 break; 538 } 539 } 540 switch (index) { 541 case UNLOAD_NOCOMPLAIN: /* -nocomplain */ 542 complain = 0; 543 break; 544 case UNLOAD_KEEPLIB: /* -keeplibrary */ 545 keepLibrary = 1; 546 break; 547 case UNLOAD_LAST: /* -- */ 548 i++; 549 goto endOfForLoop; 550 } 551 } 552 endOfForLoop: 553 if ((objc-i < 1) || (objc-i > 3)) { 554 Tcl_WrongNumArgs(interp, 1, objv, 555 "?switches? fileName ?packageName? ?interp?"); 556 return TCL_ERROR; 557 } 558 if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { 559 return TCL_ERROR; 560 } 561 562 fullFileName = Tcl_GetString(objv[i]); 563 Tcl_DStringInit(&pkgName); 564 Tcl_DStringInit(&tmp); 565 566 packageName = NULL; 567 if (objc - i >= 2) { 568 packageName = Tcl_GetString(objv[i+1]); 569 if (packageName[0] == '\0') { 570 packageName = NULL; 571 } 572 } 573 if ((fullFileName[0] == 0) && (packageName == NULL)) { 574 Tcl_SetResult(interp, 575 "must specify either file name or package name", 576 TCL_STATIC); 577 code = TCL_ERROR; 578 goto done; 579 } 580 581 /* 582 * Figure out which interpreter we're going to load the package into. 583 */ 584 585 target = interp; 586 if (objc - i == 3) { 587 char *slaveIntName; 588 slaveIntName = Tcl_GetString(objv[i+2]); 589 target = Tcl_GetSlave(interp, slaveIntName); 590 if (target == NULL) { 591 return TCL_ERROR; 592 } 593 } 594 595 /* 596 * Scan through the packages that are currently loaded to see if the 597 * package we want is already loaded. We'll use a loaded package if it 598 * meets any of the following conditions: 599 * - Its name and file match the once we're looking for. 600 * - Its file matches, and we weren't given a name. 601 * - Its name matches, the file name was specified as empty, and there is 602 * only no statically loaded package with the same name. 603 */ 604 605 Tcl_MutexLock(&packageMutex); 606 607 defaultPtr = NULL; 608 for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { 609 int namesMatch, filesMatch; 610 611 if (packageName == NULL) { 612 namesMatch = 0; 613 } else { 614 Tcl_DStringSetLength(&pkgName, 0); 615 Tcl_DStringAppend(&pkgName, packageName, -1); 616 Tcl_DStringSetLength(&tmp, 0); 617 Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); 618 Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); 619 Tcl_UtfToLower(Tcl_DStringValue(&tmp)); 620 if (strcmp(Tcl_DStringValue(&tmp), 621 Tcl_DStringValue(&pkgName)) == 0) { 622 namesMatch = 1; 623 } else { 624 namesMatch = 0; 625 } 626 } 627 Tcl_DStringSetLength(&pkgName, 0); 628 629 filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); 630 if (filesMatch && (namesMatch || (packageName == NULL))) { 631 break; 632 } 633 if (namesMatch && (fullFileName[0] == 0)) { 634 defaultPtr = pkgPtr; 635 } 636 if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { 637 break; 638 } 639 } 640 Tcl_MutexUnlock(&packageMutex); 641 if (fullFileName[0] == 0) { 642 /* 643 * It's an error to try unload a static package. 644 */ 645 646 Tcl_AppendResult(interp, "package \"", packageName, 647 "\" is loaded statically and cannot be unloaded", NULL); 648 code = TCL_ERROR; 649 goto done; 650 } 651 if (pkgPtr == NULL) { 652 /* 653 * The DLL pointed by the provided filename has never been loaded. 654 */ 655 656 Tcl_AppendResult(interp, "file \"", fullFileName, 657 "\" has never been loaded", NULL); 658 code = TCL_ERROR; 659 goto done; 660 } 661 662 /* 663 * Scan through the list of packages already loaded in the target 664 * interpreter. If the package we want is already loaded there, then we 665 * should proceed with unloading. 666 */ 667 668 code = TCL_ERROR; 669 if (pkgPtr != NULL) { 670 ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, 671 "tclLoad", NULL); 672 for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { 673 if (ipPtr->pkgPtr == pkgPtr) { 674 code = TCL_OK; 675 break; 676 } 677 } 678 } 679 if (code != TCL_OK) { 680 /* 681 * The package has not been loaded in this interpreter. 682 */ 683 684 Tcl_AppendResult(interp, "file \"", fullFileName, 685 "\" has never been loaded in this interpreter", NULL); 686 code = TCL_ERROR; 687 goto done; 688 } 689 690 /* 691 * Ensure that the DLL can be unloaded. If it is a trusted interpreter, 692 * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If 693 * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. 694 */ 695 696 if (Tcl_IsSafe(target)) { 697 if (pkgPtr->safeUnloadProc == NULL) { 698 Tcl_AppendResult(interp, "file \"", fullFileName, 699 "\" cannot be unloaded under a safe interpreter", NULL); 700 code = TCL_ERROR; 701 goto done; 702 } 703 unloadProc = pkgPtr->safeUnloadProc; 704 } else { 705 if (pkgPtr->unloadProc == NULL) { 706 Tcl_AppendResult(interp, "file \"", fullFileName, 707 "\" cannot be unloaded under a trusted interpreter", NULL); 708 code = TCL_ERROR; 709 goto done; 710 } 711 unloadProc = pkgPtr->unloadProc; 712 } 713 714 /* 715 * We are ready to unload the package. First, evaluate the unload 716 * function. If this fails, we cannot proceed with unload. Also, we must 717 * specify the proper flag to pass to the unload callback. 718 * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should 719 * only remove itself from the interpreter; the library will be unloaded 720 * in a future call of unload. In case the library will be unloaded just 721 * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. 722 */ 723 724 code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; 725 if (!keepLibrary) { 726 Tcl_MutexLock(&packageMutex); 727 trustedRefCount = pkgPtr->interpRefCount; 728 safeRefCount = pkgPtr->safeInterpRefCount; 729 Tcl_MutexUnlock(&packageMutex); 730 731 if (Tcl_IsSafe(target)) { 732 --safeRefCount; 733 } else { 734 --trustedRefCount; 735 } 736 737 if (safeRefCount <= 0 && trustedRefCount <= 0) { 738 code = TCL_UNLOAD_DETACH_FROM_PROCESS; 739 } 740 } 741 code = (*unloadProc)(target, code); 742 if (code != TCL_OK) { 743 TclTransferResult(target, code, interp); 744 goto done; 745 } 746 747 /* 748 * The unload function executed fine. Examine the reference count to see 749 * if we unload the DLL. 750 */ 751 752 Tcl_MutexLock(&packageMutex); 753 if (Tcl_IsSafe(target)) { 754 --pkgPtr->safeInterpRefCount; 755 756 /* 757 * Do not let counter get negative. 758 */ 759 760 if (pkgPtr->safeInterpRefCount < 0) { 761 pkgPtr->safeInterpRefCount = 0; 762 } 763 } else { 764 --pkgPtr->interpRefCount; 765 766 /* 767 * Do not let counter get negative. 768 */ 769 770 if (pkgPtr->interpRefCount < 0) { 771 pkgPtr->interpRefCount = 0; 772 } 773 } 774 trustedRefCount = pkgPtr->interpRefCount; 775 safeRefCount = pkgPtr->safeInterpRefCount; 776 Tcl_MutexUnlock(&packageMutex); 777 778 code = TCL_OK; 779 if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 780 && !keepLibrary) { 781 /* 782 * Unload the shared library from the application memory... 783 */ 784 785#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) 786 /* 787 * Some Unix dlls are poorly behaved - registering things like atexit 788 * calls that can't be unregistered. If you unload such dlls, you get 789 * a core on exit because it wants to call a function in the dll after 790 * it's been unloaded. 791 */ 792 793 if (pkgPtr->fileName[0] != '\0') { 794 Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; 795 796 if (unLoadProcPtr != NULL) { 797 Tcl_MutexLock(&packageMutex); 798 if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) { 799 (*unLoadProcPtr)(pkgPtr->loadHandle); 800 } 801 802 /* 803 * Remove this library from the loaded library cache. 804 */ 805 806 defaultPtr = pkgPtr; 807 if (defaultPtr == firstPackagePtr) { 808 firstPackagePtr = pkgPtr->nextPtr; 809 } else { 810 for (pkgPtr = firstPackagePtr; pkgPtr != NULL; 811 pkgPtr = pkgPtr->nextPtr) { 812 if (pkgPtr->nextPtr == defaultPtr) { 813 pkgPtr->nextPtr = defaultPtr->nextPtr; 814 break; 815 } 816 } 817 } 818 819 /* 820 * Remove this library from the interpreter's library cache. 821 */ 822 823 ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, 824 "tclLoad", NULL); 825 ipPtr = ipFirstPtr; 826 if (ipPtr->pkgPtr == defaultPtr) { 827 ipFirstPtr = ipFirstPtr->nextPtr; 828 } else { 829 InterpPackage *ipPrevPtr; 830 831 for (ipPrevPtr = ipPtr; ipPtr != NULL; 832 ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { 833 if (ipPtr->pkgPtr == pkgPtr) { 834 ipPrevPtr->nextPtr = ipPtr->nextPtr; 835 break; 836 } 837 } 838 } 839 Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, 840 (ClientData) ipFirstPtr); 841 ckfree(defaultPtr->fileName); 842 ckfree(defaultPtr->packageName); 843 ckfree((char *) defaultPtr); 844 ckfree((char *) ipPtr); 845 Tcl_MutexUnlock(&packageMutex); 846 } else { 847 Tcl_AppendResult(interp, "file \"", fullFileName, 848 "\" cannot be unloaded: filesystem does not support unloading", 849 NULL); 850 code = TCL_ERROR; 851 } 852 } 853#else 854 Tcl_AppendResult(interp, "file \"", fullFileName, 855 "\" cannot be unloaded: unloading disabled", NULL); 856 code = TCL_ERROR; 857#endif 858 } 859 860 done: 861 Tcl_DStringFree(&pkgName); 862 Tcl_DStringFree(&tmp); 863 if (!complain && code!=TCL_OK) { 864 code = TCL_OK; 865 Tcl_ResetResult(interp); 866 } 867 if (code == TCL_OK) { 868#if 0 869 /* 870 * Result of [unload] was not documented in TIP#100, so force to be 871 * the empty string by commenting this out. DKF. 872 */ 873 874 Tcl_Obj *resultObjPtr, *objPtr[2]; 875 876 /* 877 * Our result is the two reference counts. 878 */ 879 880 objPtr[0] = Tcl_NewIntObj(trustedRefCount); 881 objPtr[1] = Tcl_NewIntObj(safeRefCount); 882 if (objPtr[0] == NULL || objPtr[1] == NULL) { 883 if (objPtr[0]) { 884 Tcl_DecrRefCount(objPtr[0]); 885 } 886 if (objPtr[1]) { 887 Tcl_DecrRefCount(objPtr[1]); 888 } 889 } else { 890 resultObjPtr = Tcl_NewListObj(2, objPtr); 891 if (resultObjPtr != NULL) { 892 Tcl_SetObjResult(interp, resultObjPtr); 893 } 894 } 895#endif 896 } 897 return code; 898} 899 900/* 901 *---------------------------------------------------------------------- 902 * 903 * Tcl_StaticPackage -- 904 * 905 * This function is invoked to indicate that a particular package has 906 * been linked statically with an application. 907 * 908 * Results: 909 * None. 910 * 911 * Side effects: 912 * Once this function completes, the package becomes loadable via the 913 * "load" command with an empty file name. 914 * 915 *---------------------------------------------------------------------- 916 */ 917 918void 919Tcl_StaticPackage( 920 Tcl_Interp *interp, /* If not NULL, it means that the package has 921 * already been loaded into the given 922 * interpreter by calling the appropriate init 923 * proc. */ 924 const char *pkgName, /* Name of package (must be properly 925 * capitalized: first letter upper case, 926 * others lower case). */ 927 Tcl_PackageInitProc *initProc, 928 /* Function to call to incorporate this 929 * package into a trusted interpreter. */ 930 Tcl_PackageInitProc *safeInitProc) 931 /* Function to call to incorporate this 932 * package into a safe interpreter (one that 933 * will execute untrusted scripts). NULL means 934 * the package can't be used in safe 935 * interpreters. */ 936{ 937 LoadedPackage *pkgPtr; 938 InterpPackage *ipPtr, *ipFirstPtr; 939 940 /* 941 * Check to see if someone else has already reported this package as 942 * statically loaded in the process. 943 */ 944 945 Tcl_MutexLock(&packageMutex); 946 for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { 947 if ((pkgPtr->initProc == initProc) 948 && (pkgPtr->safeInitProc == safeInitProc) 949 && (strcmp(pkgPtr->packageName, pkgName) == 0)) { 950 break; 951 } 952 } 953 Tcl_MutexUnlock(&packageMutex); 954 955 /* 956 * If the package is not yet recorded as being loaded statically, add it 957 * to the list now. 958 */ 959 960 if ( pkgPtr == NULL ) { 961 pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); 962 pkgPtr->fileName = (char *) ckalloc((unsigned) 1); 963 pkgPtr->fileName[0] = 0; 964 pkgPtr->packageName = (char *) 965 ckalloc((unsigned) (strlen(pkgName) + 1)); 966 strcpy(pkgPtr->packageName, pkgName); 967 pkgPtr->loadHandle = NULL; 968 pkgPtr->initProc = initProc; 969 pkgPtr->safeInitProc = safeInitProc; 970 Tcl_MutexLock(&packageMutex); 971 pkgPtr->nextPtr = firstPackagePtr; 972 firstPackagePtr = pkgPtr; 973 Tcl_MutexUnlock(&packageMutex); 974 } 975 976 if (interp != NULL) { 977 978 /* 979 * If we're loading the package into an interpreter, determine whether 980 * it's already loaded. 981 */ 982 983 ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, 984 "tclLoad", NULL); 985 for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { 986 if ( ipPtr->pkgPtr == pkgPtr ) { 987 return; 988 } 989 } 990 991 /* 992 * Package isn't loade in the current interp yet. Mark it as now being 993 * loaded. 994 */ 995 996 ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); 997 ipPtr->pkgPtr = pkgPtr; 998 ipPtr->nextPtr = ipFirstPtr; 999 Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, 1000 (ClientData) ipPtr); 1001 } 1002} 1003 1004/* 1005 *---------------------------------------------------------------------- 1006 * 1007 * TclGetLoadedPackages -- 1008 * 1009 * This function returns information about all of the files that are 1010 * loaded (either in a particular intepreter, or for all interpreters). 1011 * 1012 * Results: 1013 * The return value is a standard Tcl completion code. If successful, a 1014 * list of lists is placed in the interp's result. Each sublist 1015 * corresponds to one loaded file; its first element is the name of the 1016 * file (or an empty string for something that's statically loaded) and 1017 * the second element is the name of the package in that file. 1018 * 1019 * Side effects: 1020 * None. 1021 * 1022 *---------------------------------------------------------------------- 1023 */ 1024 1025int 1026TclGetLoadedPackages( 1027 Tcl_Interp *interp, /* Interpreter in which to return information 1028 * or error message. */ 1029 char *targetName) /* Name of target interpreter or NULL. If 1030 * NULL, return info about all interps; 1031 * otherwise, just return info about this 1032 * interpreter. */ 1033{ 1034 Tcl_Interp *target; 1035 LoadedPackage *pkgPtr; 1036 InterpPackage *ipPtr; 1037 const char *prefix; 1038 1039 if (targetName == NULL) { 1040 /* 1041 * Return information about all of the available packages. 1042 */ 1043 1044 prefix = "{"; 1045 Tcl_MutexLock(&packageMutex); 1046 for (pkgPtr = firstPackagePtr; pkgPtr != NULL; 1047 pkgPtr = pkgPtr->nextPtr) { 1048 Tcl_AppendResult(interp, prefix, NULL); 1049 Tcl_AppendElement(interp, pkgPtr->fileName); 1050 Tcl_AppendElement(interp, pkgPtr->packageName); 1051 Tcl_AppendResult(interp, "}", NULL); 1052 prefix = " {"; 1053 } 1054 Tcl_MutexUnlock(&packageMutex); 1055 return TCL_OK; 1056 } 1057 1058 /* 1059 * Return information about only the packages that are loaded in a given 1060 * interpreter. 1061 */ 1062 1063 target = Tcl_GetSlave(interp, targetName); 1064 if (target == NULL) { 1065 return TCL_ERROR; 1066 } 1067 ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", NULL); 1068 prefix = "{"; 1069 for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { 1070 pkgPtr = ipPtr->pkgPtr; 1071 Tcl_AppendResult(interp, prefix, NULL); 1072 Tcl_AppendElement(interp, pkgPtr->fileName); 1073 Tcl_AppendElement(interp, pkgPtr->packageName); 1074 Tcl_AppendResult(interp, "}", NULL); 1075 prefix = " {"; 1076 } 1077 return TCL_OK; 1078} 1079 1080/* 1081 *---------------------------------------------------------------------- 1082 * 1083 * LoadCleanupProc -- 1084 * 1085 * This function is called to delete all of the InterpPackage structures 1086 * for an interpreter when the interpreter is deleted. It gets invoked 1087 * via the Tcl AssocData mechanism. 1088 * 1089 * Results: 1090 * None. 1091 * 1092 * Side effects: 1093 * Storage for all of the InterpPackage functions for interp get deleted. 1094 * 1095 *---------------------------------------------------------------------- 1096 */ 1097 1098static void 1099LoadCleanupProc( 1100 ClientData clientData, /* Pointer to first InterpPackage structure 1101 * for interp. */ 1102 Tcl_Interp *interp) /* Interpreter that is being deleted. */ 1103{ 1104 InterpPackage *ipPtr, *nextPtr; 1105 1106 ipPtr = (InterpPackage *) clientData; 1107 while (ipPtr != NULL) { 1108 nextPtr = ipPtr->nextPtr; 1109 ckfree((char *) ipPtr); 1110 ipPtr = nextPtr; 1111 } 1112} 1113 1114/* 1115 *---------------------------------------------------------------------- 1116 * 1117 * TclFinalizeLoad -- 1118 * 1119 * This function is invoked just before the application exits. It frees 1120 * all of the LoadedPackage structures. 1121 * 1122 * Results: 1123 * None. 1124 * 1125 * Side effects: 1126 * Memory is freed. 1127 * 1128 *---------------------------------------------------------------------- 1129 */ 1130 1131void 1132TclFinalizeLoad(void) 1133{ 1134 LoadedPackage *pkgPtr; 1135 1136 /* 1137 * No synchronization here because there should just be one thread alive 1138 * at this point. Logically, packageMutex should be grabbed at this point, 1139 * but the Mutexes get finalized before the call to this routine. The 1140 * only subsystem left alive at this point is the memory allocator. 1141 */ 1142 1143 while (firstPackagePtr != NULL) { 1144 pkgPtr = firstPackagePtr; 1145 firstPackagePtr = pkgPtr->nextPtr; 1146 1147#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) 1148 /* 1149 * Some Unix dlls are poorly behaved - registering things like atexit 1150 * calls that can't be unregistered. If you unload such dlls, you get 1151 * a core on exit because it wants to call a function in the dll after 1152 * it has been unloaded. 1153 */ 1154 1155 if (pkgPtr->fileName[0] != '\0') { 1156 Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; 1157 if ((unLoadProcPtr != NULL) 1158 && ((pkgPtr->unloadProc != NULL) 1159 || (unLoadProcPtr == TclFSUnloadTempFile))) { 1160 (*unLoadProcPtr)(pkgPtr->loadHandle); 1161 } 1162 } 1163#endif 1164 1165 ckfree(pkgPtr->fileName); 1166 ckfree(pkgPtr->packageName); 1167 ckfree((char *) pkgPtr); 1168 } 1169} 1170 1171/* 1172 * Local Variables: 1173 * mode: c 1174 * c-basic-offset: 4 1175 * fill-column: 78 1176 * End: 1177 */ 1178