/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sf_code/esrgpcpj/shared/tcl_base/tclload.c revision 25 by dashley, Sat Oct 8 06:43:03 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $ */  
   
 /*  
  * tclLoad.c --  
  *  
  *      This file provides the generic portion (those that are the same  
  *      on all platforms) of Tcl's dynamic loading facilities.  
  *  
  * Copyright (c) 1995-1997 Sun Microsystems, Inc.  
  *  
  * See the file "license.terms" for information on usage and redistribution  
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.  
  *  
  * RCS: @(#) $Id: tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
   
 /*  
  * The following structure describes a package that has been loaded  
  * either dynamically (with the "load" command) or statically (as  
  * indicated by a call to TclGetLoadedPackages).  All such packages  
  * are linked together into a single list for the process.  Packages  
  * are never unloaded, so these structures are never freed.  
  */  
   
 typedef struct LoadedPackage {  
     char *fileName;             /* Name of the file from which the  
                                  * package was loaded.  An empty string  
                                  * means the package is loaded statically.  
                                  * Malloc-ed. */  
     char *packageName;          /* Name of package prefix for the package,  
                                  * properly capitalized (first letter UC,  
                                  * others LC), no "_", as in "Net".  
                                  * Malloc-ed. */  
     ClientData clientData;      /* Token for the loaded file which should be  
                                  * passed to TclpUnloadFile() when the file  
                                  * is no longer needed.  If fileName is NULL,  
                                  * then this field is irrelevant. */  
     Tcl_PackageInitProc *initProc;  
                                 /* Initialization procedure to call to  
                                  * incorporate this package into a trusted  
                                  * interpreter. */  
     Tcl_PackageInitProc *safeInitProc;  
                                 /* Initialization procedure to call to  
                                  * incorporate this package into a safe  
                                  * interpreter (one that will execute  
                                  * untrusted scripts).   NULL means the  
                                  * package can't be used in unsafe  
                                  * interpreters. */  
     struct LoadedPackage *nextPtr;  
                                 /* Next in list of all packages loaded into  
                                  * this application process.  NULL means  
                                  * end of list. */  
 } LoadedPackage;  
   
 /*  
  * TCL_THREADS  
  * There is a global list of packages that is anchored at firstPackagePtr.  
  * Access to this list is governed by a mutex.  
  */  
   
 static LoadedPackage *firstPackagePtr = NULL;  
                                 /* First in list of all packages loaded into  
                                  * this process. */  
   
 TCL_DECLARE_MUTEX(packageMutex)  
   
 /*  
  * The following structure represents a particular package that has  
  * been incorporated into a particular interpreter (by calling its  
  * initialization procedure).  There is a list of these structures for  
  * each interpreter, with an AssocData value (key "load") for the  
  * interpreter that points to the first package (if any).  
  */  
   
 typedef struct InterpPackage {  
     LoadedPackage *pkgPtr;      /* Points to detailed information about  
                                  * package. */  
     struct InterpPackage *nextPtr;  
                                 /* Next package in this interpreter, or  
                                  * NULL for end of list. */  
 } InterpPackage;  
   
 /*  
  * Prototypes for procedures that are private to this file:  
  */  
   
 static void             LoadCleanupProc _ANSI_ARGS_((ClientData clientData,  
                             Tcl_Interp *interp));  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LoadObjCmd --  
  *  
  *      This procedure is invoked to process the "load" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 Tcl_LoadObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Tcl_Interp *target;  
     LoadedPackage *pkgPtr, *defaultPtr;  
     Tcl_DString pkgName, tmp, initName, safeInitName, fileName;  
     Tcl_PackageInitProc *initProc, *safeInitProc;  
     InterpPackage *ipFirstPtr, *ipPtr;  
     int code, namesMatch, filesMatch;  
     char *p, *tempString, *fullFileName, *packageName;  
     ClientData clientData;  
     Tcl_UniChar ch;  
     int offset;  
   
     if ((objc < 2) || (objc > 4)) {  
         Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");  
         return TCL_ERROR;  
     }  
     tempString = Tcl_GetString(objv[1]);  
     fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);  
     if (fullFileName == NULL) {  
         return TCL_ERROR;  
     }  
     Tcl_DStringInit(&pkgName);  
     Tcl_DStringInit(&initName);  
     Tcl_DStringInit(&safeInitName);  
     Tcl_DStringInit(&tmp);  
   
     packageName = NULL;  
     if (objc >= 3) {  
         packageName = Tcl_GetString(objv[2]);  
         if (packageName[0] == '\0') {  
             packageName = NULL;  
         }  
     }  
     if ((fullFileName[0] == 0) && (packageName == NULL)) {  
         Tcl_SetResult(interp,  
                 "must specify either file name or package name",  
                 TCL_STATIC);  
         code = TCL_ERROR;  
         goto done;  
     }  
   
     /*  
      * Figure out which interpreter we're going to load the package into.  
      */  
   
     target = interp;  
     if (objc == 4) {  
         char *slaveIntName;  
         slaveIntName = Tcl_GetString(objv[3]);  
         target = Tcl_GetSlave(interp, slaveIntName);  
         if (target == NULL) {  
             return TCL_ERROR;  
         }  
     }  
   
     /*  
      * Scan through the packages that are currently loaded to see if the  
      * package we want is already loaded.  We'll use a loaded package if  
      * it meets any of the following conditions:  
      *  - Its name and file match the once we're looking for.  
      *  - Its file matches, and we weren't given a name.  
      *  - Its name matches, the file name was specified as empty, and there  
      *    is only no statically loaded package with the same name.  
      */  
     Tcl_MutexLock(&packageMutex);  
   
     defaultPtr = NULL;  
     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {  
         if (packageName == NULL) {  
             namesMatch = 0;  
         } else {  
             Tcl_DStringSetLength(&pkgName, 0);  
             Tcl_DStringAppend(&pkgName, packageName, -1);  
             Tcl_DStringSetLength(&tmp, 0);  
             Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);  
             Tcl_UtfToLower(Tcl_DStringValue(&pkgName));  
             Tcl_UtfToLower(Tcl_DStringValue(&tmp));  
             if (strcmp(Tcl_DStringValue(&tmp),  
                     Tcl_DStringValue(&pkgName)) == 0) {  
                 namesMatch = 1;  
             } else {  
                 namesMatch = 0;  
             }  
         }  
         Tcl_DStringSetLength(&pkgName, 0);  
   
         filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);  
         if (filesMatch && (namesMatch || (packageName == NULL))) {  
             break;  
         }  
         if (namesMatch && (fullFileName[0] == 0)) {  
             defaultPtr = pkgPtr;  
         }  
         if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {  
             /*  
              * Can't have two different packages loaded from the same  
              * file.  
              */  
   
             Tcl_AppendResult(interp, "file \"", fullFileName,  
                     "\" is already loaded for package \"",  
                     pkgPtr->packageName, "\"", (char *) NULL);  
             code = TCL_ERROR;  
             Tcl_MutexUnlock(&packageMutex);  
             goto done;  
         }  
     }  
     Tcl_MutexUnlock(&packageMutex);  
     if (pkgPtr == NULL) {  
         pkgPtr = defaultPtr;  
     }  
   
     /*  
      * Scan through the list of packages already loaded in the target  
      * interpreter.  If the package we want is already loaded there,  
      * then there's nothing for us to to.  
      */  
   
     if (pkgPtr != NULL) {  
         ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",  
                 (Tcl_InterpDeleteProc **) NULL);  
         for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {  
             if (ipPtr->pkgPtr == pkgPtr) {  
                 code = TCL_OK;  
                 goto done;  
             }  
         }  
     }  
   
     if (pkgPtr == NULL) {  
         /*  
          * The desired file isn't currently loaded, so load it.  It's an  
          * error if the desired package is a static one.  
          */  
   
         if (fullFileName[0] == 0) {  
             Tcl_AppendResult(interp, "package \"", packageName,  
                     "\" isn't loaded statically", (char *) NULL);  
             code = TCL_ERROR;  
             goto done;  
         }  
   
         /*  
          * Figure out the module name if it wasn't provided explicitly.  
          */  
   
         if (packageName != NULL) {  
             Tcl_DStringAppend(&pkgName, packageName, -1);  
         } else {  
             int retc;  
             /*  
              * Threading note - this call used to be protected by a mutex.  
              */  
             retc = TclGuessPackageName(fullFileName, &pkgName);  
             if (!retc) {  
                 int pargc;  
                 char **pargv, *pkgGuess;  
   
                 /*  
                  * The platform-specific code couldn't figure out the  
                  * module name.  Make a guess by taking the last element  
                  * of the file name, stripping off any leading "lib",  
                  * and then using all of the alphabetic and underline  
                  * characters that follow that.  
                  */  
   
                 Tcl_SplitPath(fullFileName, &pargc, &pargv);  
                 pkgGuess = pargv[pargc-1];  
                 if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')  
                         && (pkgGuess[2] == 'b')) {  
                     pkgGuess += 3;  
                 }  
                 for (p = pkgGuess; *p != 0; p += offset) {  
                     offset = Tcl_UtfToUniChar(p, &ch);  
                     if ((ch > 0x100)  
                             || !(isalpha(UCHAR(ch)) /* INTL: ISO only */  
                                     || (UCHAR(ch) == '_'))) {  
                         break;  
                     }  
                 }  
                 if (p == pkgGuess) {  
                     ckfree((char *)pargv);  
                     Tcl_AppendResult(interp,  
                             "couldn't figure out package name for ",  
                             fullFileName, (char *) NULL);  
                     code = TCL_ERROR;  
                     goto done;  
                 }  
                 Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));  
                 ckfree((char *)pargv);  
             }  
         }  
   
         /*  
          * Fix the capitalization in the package name so that the first  
          * character is in caps (or title case) but the others are all  
          * lower-case.  
          */  
       
         Tcl_DStringSetLength(&pkgName,  
                 Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));  
   
         /*  
          * Compute the names of the two initialization procedures,  
          * based on the package name.  
          */  
       
         Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);  
         Tcl_DStringAppend(&initName, "_Init", 5);  
         Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);  
         Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);  
   
         /*  
          * Call platform-specific code to load the package and find the  
          * two initialization procedures.  
          */  
   
         Tcl_MutexLock(&packageMutex);  
         code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),  
                 Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,  
                 &clientData);  
         Tcl_MutexUnlock(&packageMutex);  
         if (code != TCL_OK) {  
             goto done;  
         }  
         if (initProc == NULL) {  
             Tcl_AppendResult(interp, "couldn't find procedure ",  
                     Tcl_DStringValue(&initName), (char *) NULL);  
             TclpUnloadFile(clientData);  
             code = TCL_ERROR;  
             goto done;  
         }  
   
         /*  
          * Create a new record to describe this package.  
          */  
   
         pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));  
         pkgPtr->fileName        = (char *) ckalloc((unsigned)  
                 (strlen(fullFileName) + 1));  
         strcpy(pkgPtr->fileName, fullFileName);  
         pkgPtr->packageName     = (char *) ckalloc((unsigned)  
                 (Tcl_DStringLength(&pkgName) + 1));  
         strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));  
         pkgPtr->clientData      = clientData;  
         pkgPtr->initProc        = initProc;  
         pkgPtr->safeInitProc    = safeInitProc;  
         Tcl_MutexLock(&packageMutex);  
         pkgPtr->nextPtr         = firstPackagePtr;  
         firstPackagePtr         = pkgPtr;  
         Tcl_MutexUnlock(&packageMutex);  
     }  
   
     /*  
      * Invoke the package's initialization procedure (either the  
      * normal one or the safe one, depending on whether or not the  
      * interpreter is safe).  
      */  
   
     if (Tcl_IsSafe(target)) {  
         if (pkgPtr->safeInitProc != NULL) {  
             code = (*pkgPtr->safeInitProc)(target);  
         } else {  
             Tcl_AppendResult(interp,  
                     "can't use package in a safe interpreter: ",  
                     "no ", pkgPtr->packageName, "_SafeInit procedure",  
                     (char *) NULL);  
             code = TCL_ERROR;  
             goto done;  
         }  
     } else {  
         code = (*pkgPtr->initProc)(target);  
     }  
   
     /*  
      * Record the fact that the package has been loaded in the  
      * target interpreter.  
      */  
   
     if (code == TCL_OK) {  
         /*  
          * Refetch ipFirstPtr: loading the package may have introduced  
          * additional static packages at the head of the linked list!  
          */  
   
         ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",  
                 (Tcl_InterpDeleteProc **) NULL);  
         ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));  
         ipPtr->pkgPtr = pkgPtr;  
         ipPtr->nextPtr = ipFirstPtr;  
         Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,  
                 (ClientData) ipPtr);  
     } else {  
         TclTransferResult(target, code, interp);  
     }  
   
     done:  
     Tcl_DStringFree(&pkgName);  
     Tcl_DStringFree(&initName);  
     Tcl_DStringFree(&safeInitName);  
     Tcl_DStringFree(&fileName);  
     Tcl_DStringFree(&tmp);  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_StaticPackage --  
  *  
  *      This procedure is invoked to indicate that a particular  
  *      package has been linked statically with an application.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Once this procedure completes, the package becomes loadable  
  *      via the "load" command with an empty file name.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)  
     Tcl_Interp *interp;                 /* If not NULL, it means that the  
                                          * package has already been loaded  
                                          * into the given interpreter by  
                                          * calling the appropriate init proc. */  
     char *pkgName;                      /* Name of package (must be properly  
                                          * capitalized: first letter upper  
                                          * case, others lower case). */  
     Tcl_PackageInitProc *initProc;      /* Procedure to call to incorporate  
                                          * this package into a trusted  
                                          * interpreter. */  
     Tcl_PackageInitProc *safeInitProc;  /* Procedure to call to incorporate  
                                          * this package into a safe interpreter  
                                          * (one that will execute untrusted  
                                          * scripts).   NULL means the package  
                                          * can't be used in safe  
                                          * interpreters. */  
 {  
     LoadedPackage *pkgPtr;  
     InterpPackage *ipPtr, *ipFirstPtr;  
   
     /*  
      * Check to see if someone else has already reported this package as  
      * statically loaded.  If this call is redundant then just return.  
      */  
   
     Tcl_MutexLock(&packageMutex);  
     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {  
         if ((pkgPtr->initProc == initProc)  
                 && (pkgPtr->safeInitProc == safeInitProc)  
                 && (strcmp(pkgPtr->packageName, pkgName) == 0)) {  
             Tcl_MutexUnlock(&packageMutex);  
             return;  
         }  
     }  
   
     Tcl_MutexUnlock(&packageMutex);  
   
     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));  
     pkgPtr->fileName            = (char *) ckalloc((unsigned) 1);  
     pkgPtr->fileName[0]         = 0;  
     pkgPtr->packageName         = (char *) ckalloc((unsigned)  
             (strlen(pkgName) + 1));  
     strcpy(pkgPtr->packageName, pkgName);  
     pkgPtr->clientData          = NULL;  
     pkgPtr->initProc            = initProc;  
     pkgPtr->safeInitProc        = safeInitProc;  
     Tcl_MutexLock(&packageMutex);  
     pkgPtr->nextPtr             = firstPackagePtr;  
     firstPackagePtr             = pkgPtr;  
     Tcl_MutexUnlock(&packageMutex);  
   
     if (interp != NULL) {  
         ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",  
                 (Tcl_InterpDeleteProc **) NULL);  
         ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));  
         ipPtr->pkgPtr = pkgPtr;  
         ipPtr->nextPtr = ipFirstPtr;  
         Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,  
                 (ClientData) ipPtr);  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclGetLoadedPackages --  
  *  
  *      This procedure returns information about all of the files  
  *      that are loaded (either in a particular intepreter, or  
  *      for all interpreters).  
  *  
  * Results:  
  *      The return value is a standard Tcl completion code.  If  
  *      successful, a list of lists is placed in the interp's result.  
  *      Each sublist corresponds to one loaded file;  its first  
  *      element is the name of the file (or an empty string for  
  *      something that's statically loaded) and the second element  
  *      is the name of the package in that file.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclGetLoadedPackages(interp, targetName)  
     Tcl_Interp *interp;         /* Interpreter in which to return  
                                  * information or error message. */  
     char *targetName;           /* Name of target interpreter or NULL.  
                                  * If NULL, return info about all interps;  
                                  * otherwise, just return info about this  
                                  * interpreter. */  
 {  
     Tcl_Interp *target;  
     LoadedPackage *pkgPtr;  
     InterpPackage *ipPtr;  
     char *prefix;  
   
     if (targetName == NULL) {  
         /*  
          * Return information about all of the available packages.  
          */  
   
         prefix = "{";  
         Tcl_MutexLock(&packageMutex);  
         for (pkgPtr = firstPackagePtr; pkgPtr != NULL;  
                 pkgPtr = pkgPtr->nextPtr) {  
             Tcl_AppendResult(interp, prefix, (char *) NULL);  
             Tcl_AppendElement(interp, pkgPtr->fileName);  
             Tcl_AppendElement(interp, pkgPtr->packageName);  
             Tcl_AppendResult(interp, "}", (char *) NULL);  
             prefix = " {";  
         }  
         Tcl_MutexUnlock(&packageMutex);  
         return TCL_OK;  
     }  
   
     /*  
      * Return information about only the packages that are loaded in  
      * a given interpreter.  
      */  
   
     target = Tcl_GetSlave(interp, targetName);  
     if (target == NULL) {  
         return TCL_ERROR;  
     }  
     ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",  
             (Tcl_InterpDeleteProc **) NULL);  
     prefix = "{";  
     for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {  
         pkgPtr = ipPtr->pkgPtr;  
         Tcl_AppendResult(interp, prefix, (char *) NULL);  
         Tcl_AppendElement(interp, pkgPtr->fileName);  
         Tcl_AppendElement(interp, pkgPtr->packageName);  
         Tcl_AppendResult(interp, "}", (char *) NULL);  
         prefix = " {";  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * LoadCleanupProc --  
  *  
  *      This procedure is called to delete all of the InterpPackage  
  *      structures for an interpreter when the interpreter is deleted.  
  *      It gets invoked via the Tcl AssocData mechanism.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Storage for all of the InterpPackage procedures for interp  
  *      get deleted.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 LoadCleanupProc(clientData, interp)  
     ClientData clientData;      /* Pointer to first InterpPackage structure  
                                  * for interp. */  
     Tcl_Interp *interp;         /* Interpreter that is being deleted. */  
 {  
     InterpPackage *ipPtr, *nextPtr;  
   
     ipPtr = (InterpPackage *) clientData;  
     while (ipPtr != NULL) {  
         nextPtr = ipPtr->nextPtr;  
         ckfree((char *) ipPtr);  
         ipPtr = nextPtr;  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFinalizeLoad --  
  *  
  *      This procedure is invoked just before the application exits.  
  *      It frees all of the LoadedPackage structures.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Memory is freed.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclFinalizeLoad()  
 {  
     LoadedPackage *pkgPtr;  
   
     /*  
      * No synchronization here because there should just be  
      * one thread alive at this point.  Logically,  
      * packageMutex should be grabbed at this point, but  
      * the Mutexes get finalized before the call to this routine.  
      * The only subsystem left alive at this point is the  
      * memory allocator.  
      */  
   
     while (firstPackagePtr != NULL) {  
         pkgPtr = firstPackagePtr;  
         firstPackagePtr = pkgPtr->nextPtr;  
 #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)  
         /*  
          * Some Unix dlls are poorly behaved - registering things like  
          * atexit calls that can't be unregistered.  If you unload  
          * such dlls, you get a core on exit because it wants to  
          * call a function in the dll after it's been unloaded.  
          */  
         if (pkgPtr->fileName[0] != '\0') {  
             TclpUnloadFile(pkgPtr->clientData);  
         }  
 #endif  
         ckfree(pkgPtr->fileName);  
         ckfree(pkgPtr->packageName);  
         ckfree((char *) pkgPtr);  
     }  
 }  
   
   
 /* $History: tclload.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:32a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLLOAD.C */  
1    /* $Header$ */
2    /*
3     * tclLoad.c --
4     *
5     *      This file provides the generic portion (those that are the same
6     *      on all platforms) of Tcl's dynamic loading facilities.
7     *
8     * Copyright (c) 1995-1997 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $
14     */
15    
16    #include "tclInt.h"
17    
18    /*
19     * The following structure describes a package that has been loaded
20     * either dynamically (with the "load" command) or statically (as
21     * indicated by a call to TclGetLoadedPackages).  All such packages
22     * are linked together into a single list for the process.  Packages
23     * are never unloaded, so these structures are never freed.
24     */
25    
26    typedef struct LoadedPackage {
27        char *fileName;             /* Name of the file from which the
28                                     * package was loaded.  An empty string
29                                     * means the package is loaded statically.
30                                     * Malloc-ed. */
31        char *packageName;          /* Name of package prefix for the package,
32                                     * properly capitalized (first letter UC,
33                                     * others LC), no "_", as in "Net".
34                                     * Malloc-ed. */
35        ClientData clientData;      /* Token for the loaded file which should be
36                                     * passed to TclpUnloadFile() when the file
37                                     * is no longer needed.  If fileName is NULL,
38                                     * then this field is irrelevant. */
39        Tcl_PackageInitProc *initProc;
40                                    /* Initialization procedure to call to
41                                     * incorporate this package into a trusted
42                                     * interpreter. */
43        Tcl_PackageInitProc *safeInitProc;
44                                    /* Initialization procedure to call to
45                                     * incorporate this package into a safe
46                                     * interpreter (one that will execute
47                                     * untrusted scripts).   NULL means the
48                                     * package can't be used in unsafe
49                                     * interpreters. */
50        struct LoadedPackage *nextPtr;
51                                    /* Next in list of all packages loaded into
52                                     * this application process.  NULL means
53                                     * end of list. */
54    } LoadedPackage;
55    
56    /*
57     * TCL_THREADS
58     * There is a global list of packages that is anchored at firstPackagePtr.
59     * Access to this list is governed by a mutex.
60     */
61    
62    static LoadedPackage *firstPackagePtr = NULL;
63                                    /* First in list of all packages loaded into
64                                     * this process. */
65    
66    TCL_DECLARE_MUTEX(packageMutex)
67    
68    /*
69     * The following structure represents a particular package that has
70     * been incorporated into a particular interpreter (by calling its
71     * initialization procedure).  There is a list of these structures for
72     * each interpreter, with an AssocData value (key "load") for the
73     * interpreter that points to the first package (if any).
74     */
75    
76    typedef struct InterpPackage {
77        LoadedPackage *pkgPtr;      /* Points to detailed information about
78                                     * package. */
79        struct InterpPackage *nextPtr;
80                                    /* Next package in this interpreter, or
81                                     * NULL for end of list. */
82    } InterpPackage;
83    
84    /*
85     * Prototypes for procedures that are private to this file:
86     */
87    
88    static void             LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
89                                Tcl_Interp *interp));
90    
91    /*
92     *----------------------------------------------------------------------
93     *
94     * Tcl_LoadObjCmd --
95     *
96     *      This procedure is invoked to process the "load" Tcl command.
97     *      See the user documentation for details on what it does.
98     *
99     * Results:
100     *      A standard Tcl result.
101     *
102     * Side effects:
103     *      See the user documentation.
104     *
105     *----------------------------------------------------------------------
106     */
107    
108    int
109    Tcl_LoadObjCmd(dummy, interp, objc, objv)
110        ClientData dummy;           /* Not used. */
111        Tcl_Interp *interp;         /* Current interpreter. */
112        int objc;                   /* Number of arguments. */
113        Tcl_Obj *CONST objv[];      /* Argument objects. */
114    {
115        Tcl_Interp *target;
116        LoadedPackage *pkgPtr, *defaultPtr;
117        Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
118        Tcl_PackageInitProc *initProc, *safeInitProc;
119        InterpPackage *ipFirstPtr, *ipPtr;
120        int code, namesMatch, filesMatch;
121        char *p, *tempString, *fullFileName, *packageName;
122        ClientData clientData;
123        Tcl_UniChar ch;
124        int offset;
125    
126        if ((objc < 2) || (objc > 4)) {
127            Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
128            return TCL_ERROR;
129        }
130        tempString = Tcl_GetString(objv[1]);
131        fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
132        if (fullFileName == NULL) {
133            return TCL_ERROR;
134        }
135        Tcl_DStringInit(&pkgName);
136        Tcl_DStringInit(&initName);
137        Tcl_DStringInit(&safeInitName);
138        Tcl_DStringInit(&tmp);
139    
140        packageName = NULL;
141        if (objc >= 3) {
142            packageName = Tcl_GetString(objv[2]);
143            if (packageName[0] == '\0') {
144                packageName = NULL;
145            }
146        }
147        if ((fullFileName[0] == 0) && (packageName == NULL)) {
148            Tcl_SetResult(interp,
149                    "must specify either file name or package name",
150                    TCL_STATIC);
151            code = TCL_ERROR;
152            goto done;
153        }
154    
155        /*
156         * Figure out which interpreter we're going to load the package into.
157         */
158    
159        target = interp;
160        if (objc == 4) {
161            char *slaveIntName;
162            slaveIntName = Tcl_GetString(objv[3]);
163            target = Tcl_GetSlave(interp, slaveIntName);
164            if (target == NULL) {
165                return TCL_ERROR;
166            }
167        }
168    
169        /*
170         * Scan through the packages that are currently loaded to see if the
171         * package we want is already loaded.  We'll use a loaded package if
172         * it meets any of the following conditions:
173         *  - Its name and file match the once we're looking for.
174         *  - Its file matches, and we weren't given a name.
175         *  - Its name matches, the file name was specified as empty, and there
176         *    is only no statically loaded package with the same name.
177         */
178        Tcl_MutexLock(&packageMutex);
179    
180        defaultPtr = NULL;
181        for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
182            if (packageName == NULL) {
183                namesMatch = 0;
184            } else {
185                Tcl_DStringSetLength(&pkgName, 0);
186                Tcl_DStringAppend(&pkgName, packageName, -1);
187                Tcl_DStringSetLength(&tmp, 0);
188                Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
189                Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
190                Tcl_UtfToLower(Tcl_DStringValue(&tmp));
191                if (strcmp(Tcl_DStringValue(&tmp),
192                        Tcl_DStringValue(&pkgName)) == 0) {
193                    namesMatch = 1;
194                } else {
195                    namesMatch = 0;
196                }
197            }
198            Tcl_DStringSetLength(&pkgName, 0);
199    
200            filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
201            if (filesMatch && (namesMatch || (packageName == NULL))) {
202                break;
203            }
204            if (namesMatch && (fullFileName[0] == 0)) {
205                defaultPtr = pkgPtr;
206            }
207            if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
208                /*
209                 * Can't have two different packages loaded from the same
210                 * file.
211                 */
212    
213                Tcl_AppendResult(interp, "file \"", fullFileName,
214                        "\" is already loaded for package \"",
215                        pkgPtr->packageName, "\"", (char *) NULL);
216                code = TCL_ERROR;
217                Tcl_MutexUnlock(&packageMutex);
218                goto done;
219            }
220        }
221        Tcl_MutexUnlock(&packageMutex);
222        if (pkgPtr == NULL) {
223            pkgPtr = defaultPtr;
224        }
225    
226        /*
227         * Scan through the list of packages already loaded in the target
228         * interpreter.  If the package we want is already loaded there,
229         * then there's nothing for us to to.
230         */
231    
232        if (pkgPtr != NULL) {
233            ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
234                    (Tcl_InterpDeleteProc **) NULL);
235            for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
236                if (ipPtr->pkgPtr == pkgPtr) {
237                    code = TCL_OK;
238                    goto done;
239                }
240            }
241        }
242    
243        if (pkgPtr == NULL) {
244            /*
245             * The desired file isn't currently loaded, so load it.  It's an
246             * error if the desired package is a static one.
247             */
248    
249            if (fullFileName[0] == 0) {
250                Tcl_AppendResult(interp, "package \"", packageName,
251                        "\" isn't loaded statically", (char *) NULL);
252                code = TCL_ERROR;
253                goto done;
254            }
255    
256            /*
257             * Figure out the module name if it wasn't provided explicitly.
258             */
259    
260            if (packageName != NULL) {
261                Tcl_DStringAppend(&pkgName, packageName, -1);
262            } else {
263                int retc;
264                /*
265                 * Threading note - this call used to be protected by a mutex.
266                 */
267                retc = TclGuessPackageName(fullFileName, &pkgName);
268                if (!retc) {
269                    int pargc;
270                    char **pargv, *pkgGuess;
271    
272                    /*
273                     * The platform-specific code couldn't figure out the
274                     * module name.  Make a guess by taking the last element
275                     * of the file name, stripping off any leading "lib",
276                     * and then using all of the alphabetic and underline
277                     * characters that follow that.
278                     */
279    
280                    Tcl_SplitPath(fullFileName, &pargc, &pargv);
281                    pkgGuess = pargv[pargc-1];
282                    if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
283                            && (pkgGuess[2] == 'b')) {
284                        pkgGuess += 3;
285                    }
286                    for (p = pkgGuess; *p != 0; p += offset) {
287                        offset = Tcl_UtfToUniChar(p, &ch);
288                        if ((ch > 0x100)
289                                || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
290                                        || (UCHAR(ch) == '_'))) {
291                            break;
292                        }
293                    }
294                    if (p == pkgGuess) {
295                        ckfree((char *)pargv);
296                        Tcl_AppendResult(interp,
297                                "couldn't figure out package name for ",
298                                fullFileName, (char *) NULL);
299                        code = TCL_ERROR;
300                        goto done;
301                    }
302                    Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
303                    ckfree((char *)pargv);
304                }
305            }
306    
307            /*
308             * Fix the capitalization in the package name so that the first
309             * character is in caps (or title case) but the others are all
310             * lower-case.
311             */
312        
313            Tcl_DStringSetLength(&pkgName,
314                    Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
315    
316            /*
317             * Compute the names of the two initialization procedures,
318             * based on the package name.
319             */
320        
321            Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
322            Tcl_DStringAppend(&initName, "_Init", 5);
323            Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
324            Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
325    
326            /*
327             * Call platform-specific code to load the package and find the
328             * two initialization procedures.
329             */
330    
331            Tcl_MutexLock(&packageMutex);
332            code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
333                    Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
334                    &clientData);
335            Tcl_MutexUnlock(&packageMutex);
336            if (code != TCL_OK) {
337                goto done;
338            }
339            if (initProc == NULL) {
340                Tcl_AppendResult(interp, "couldn't find procedure ",
341                        Tcl_DStringValue(&initName), (char *) NULL);
342                TclpUnloadFile(clientData);
343                code = TCL_ERROR;
344                goto done;
345            }
346    
347            /*
348             * Create a new record to describe this package.
349             */
350    
351            pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
352            pkgPtr->fileName        = (char *) ckalloc((unsigned)
353                    (strlen(fullFileName) + 1));
354            strcpy(pkgPtr->fileName, fullFileName);
355            pkgPtr->packageName     = (char *) ckalloc((unsigned)
356                    (Tcl_DStringLength(&pkgName) + 1));
357            strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
358            pkgPtr->clientData      = clientData;
359            pkgPtr->initProc        = initProc;
360            pkgPtr->safeInitProc    = safeInitProc;
361            Tcl_MutexLock(&packageMutex);
362            pkgPtr->nextPtr         = firstPackagePtr;
363            firstPackagePtr         = pkgPtr;
364            Tcl_MutexUnlock(&packageMutex);
365        }
366    
367        /*
368         * Invoke the package's initialization procedure (either the
369         * normal one or the safe one, depending on whether or not the
370         * interpreter is safe).
371         */
372    
373        if (Tcl_IsSafe(target)) {
374            if (pkgPtr->safeInitProc != NULL) {
375                code = (*pkgPtr->safeInitProc)(target);
376            } else {
377                Tcl_AppendResult(interp,
378                        "can't use package in a safe interpreter: ",
379                        "no ", pkgPtr->packageName, "_SafeInit procedure",
380                        (char *) NULL);
381                code = TCL_ERROR;
382                goto done;
383            }
384        } else {
385            code = (*pkgPtr->initProc)(target);
386        }
387    
388        /*
389         * Record the fact that the package has been loaded in the
390         * target interpreter.
391         */
392    
393        if (code == TCL_OK) {
394            /*
395             * Refetch ipFirstPtr: loading the package may have introduced
396             * additional static packages at the head of the linked list!
397             */
398    
399            ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
400                    (Tcl_InterpDeleteProc **) NULL);
401            ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
402            ipPtr->pkgPtr = pkgPtr;
403            ipPtr->nextPtr = ipFirstPtr;
404            Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
405                    (ClientData) ipPtr);
406        } else {
407            TclTransferResult(target, code, interp);
408        }
409    
410        done:
411        Tcl_DStringFree(&pkgName);
412        Tcl_DStringFree(&initName);
413        Tcl_DStringFree(&safeInitName);
414        Tcl_DStringFree(&fileName);
415        Tcl_DStringFree(&tmp);
416        return code;
417    }
418    
419    /*
420     *----------------------------------------------------------------------
421     *
422     * Tcl_StaticPackage --
423     *
424     *      This procedure is invoked to indicate that a particular
425     *      package has been linked statically with an application.
426     *
427     * Results:
428     *      None.
429     *
430     * Side effects:
431     *      Once this procedure completes, the package becomes loadable
432     *      via the "load" command with an empty file name.
433     *
434     *----------------------------------------------------------------------
435     */
436    
437    void
438    Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
439        Tcl_Interp *interp;                 /* If not NULL, it means that the
440                                             * package has already been loaded
441                                             * into the given interpreter by
442                                             * calling the appropriate init proc. */
443        char *pkgName;                      /* Name of package (must be properly
444                                             * capitalized: first letter upper
445                                             * case, others lower case). */
446        Tcl_PackageInitProc *initProc;      /* Procedure to call to incorporate
447                                             * this package into a trusted
448                                             * interpreter. */
449        Tcl_PackageInitProc *safeInitProc;  /* Procedure to call to incorporate
450                                             * this package into a safe interpreter
451                                             * (one that will execute untrusted
452                                             * scripts).   NULL means the package
453                                             * can't be used in safe
454                                             * interpreters. */
455    {
456        LoadedPackage *pkgPtr;
457        InterpPackage *ipPtr, *ipFirstPtr;
458    
459        /*
460         * Check to see if someone else has already reported this package as
461         * statically loaded.  If this call is redundant then just return.
462         */
463    
464        Tcl_MutexLock(&packageMutex);
465        for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
466            if ((pkgPtr->initProc == initProc)
467                    && (pkgPtr->safeInitProc == safeInitProc)
468                    && (strcmp(pkgPtr->packageName, pkgName) == 0)) {
469                Tcl_MutexUnlock(&packageMutex);
470                return;
471            }
472        }
473    
474        Tcl_MutexUnlock(&packageMutex);
475    
476        pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
477        pkgPtr->fileName            = (char *) ckalloc((unsigned) 1);
478        pkgPtr->fileName[0]         = 0;
479        pkgPtr->packageName         = (char *) ckalloc((unsigned)
480                (strlen(pkgName) + 1));
481        strcpy(pkgPtr->packageName, pkgName);
482        pkgPtr->clientData          = NULL;
483        pkgPtr->initProc            = initProc;
484        pkgPtr->safeInitProc        = safeInitProc;
485        Tcl_MutexLock(&packageMutex);
486        pkgPtr->nextPtr             = firstPackagePtr;
487        firstPackagePtr             = pkgPtr;
488        Tcl_MutexUnlock(&packageMutex);
489    
490        if (interp != NULL) {
491            ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
492                    (Tcl_InterpDeleteProc **) NULL);
493            ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
494            ipPtr->pkgPtr = pkgPtr;
495            ipPtr->nextPtr = ipFirstPtr;
496            Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
497                    (ClientData) ipPtr);
498        }
499    }
500    
501    /*
502     *----------------------------------------------------------------------
503     *
504     * TclGetLoadedPackages --
505     *
506     *      This procedure returns information about all of the files
507     *      that are loaded (either in a particular intepreter, or
508     *      for all interpreters).
509     *
510     * Results:
511     *      The return value is a standard Tcl completion code.  If
512     *      successful, a list of lists is placed in the interp's result.
513     *      Each sublist corresponds to one loaded file;  its first
514     *      element is the name of the file (or an empty string for
515     *      something that's statically loaded) and the second element
516     *      is the name of the package in that file.
517     *
518     * Side effects:
519     *      None.
520     *
521     *----------------------------------------------------------------------
522     */
523    
524    int
525    TclGetLoadedPackages(interp, targetName)
526        Tcl_Interp *interp;         /* Interpreter in which to return
527                                     * information or error message. */
528        char *targetName;           /* Name of target interpreter or NULL.
529                                     * If NULL, return info about all interps;
530                                     * otherwise, just return info about this
531                                     * interpreter. */
532    {
533        Tcl_Interp *target;
534        LoadedPackage *pkgPtr;
535        InterpPackage *ipPtr;
536        char *prefix;
537    
538        if (targetName == NULL) {
539            /*
540             * Return information about all of the available packages.
541             */
542    
543            prefix = "{";
544            Tcl_MutexLock(&packageMutex);
545            for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
546                    pkgPtr = pkgPtr->nextPtr) {
547                Tcl_AppendResult(interp, prefix, (char *) NULL);
548                Tcl_AppendElement(interp, pkgPtr->fileName);
549                Tcl_AppendElement(interp, pkgPtr->packageName);
550                Tcl_AppendResult(interp, "}", (char *) NULL);
551                prefix = " {";
552            }
553            Tcl_MutexUnlock(&packageMutex);
554            return TCL_OK;
555        }
556    
557        /*
558         * Return information about only the packages that are loaded in
559         * a given interpreter.
560         */
561    
562        target = Tcl_GetSlave(interp, targetName);
563        if (target == NULL) {
564            return TCL_ERROR;
565        }
566        ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
567                (Tcl_InterpDeleteProc **) NULL);
568        prefix = "{";
569        for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
570            pkgPtr = ipPtr->pkgPtr;
571            Tcl_AppendResult(interp, prefix, (char *) NULL);
572            Tcl_AppendElement(interp, pkgPtr->fileName);
573            Tcl_AppendElement(interp, pkgPtr->packageName);
574            Tcl_AppendResult(interp, "}", (char *) NULL);
575            prefix = " {";
576        }
577        return TCL_OK;
578    }
579    
580    /*
581     *----------------------------------------------------------------------
582     *
583     * LoadCleanupProc --
584     *
585     *      This procedure is called to delete all of the InterpPackage
586     *      structures for an interpreter when the interpreter is deleted.
587     *      It gets invoked via the Tcl AssocData mechanism.
588     *
589     * Results:
590     *      None.
591     *
592     * Side effects:
593     *      Storage for all of the InterpPackage procedures for interp
594     *      get deleted.
595     *
596     *----------------------------------------------------------------------
597     */
598    
599    static void
600    LoadCleanupProc(clientData, interp)
601        ClientData clientData;      /* Pointer to first InterpPackage structure
602                                     * for interp. */
603        Tcl_Interp *interp;         /* Interpreter that is being deleted. */
604    {
605        InterpPackage *ipPtr, *nextPtr;
606    
607        ipPtr = (InterpPackage *) clientData;
608        while (ipPtr != NULL) {
609            nextPtr = ipPtr->nextPtr;
610            ckfree((char *) ipPtr);
611            ipPtr = nextPtr;
612        }
613    }
614    
615    /*
616     *----------------------------------------------------------------------
617     *
618     * TclFinalizeLoad --
619     *
620     *      This procedure is invoked just before the application exits.
621     *      It frees all of the LoadedPackage structures.
622     *
623     * Results:
624     *      None.
625     *
626     * Side effects:
627     *      Memory is freed.
628     *
629     *----------------------------------------------------------------------
630     */
631    
632    void
633    TclFinalizeLoad()
634    {
635        LoadedPackage *pkgPtr;
636    
637        /*
638         * No synchronization here because there should just be
639         * one thread alive at this point.  Logically,
640         * packageMutex should be grabbed at this point, but
641         * the Mutexes get finalized before the call to this routine.
642         * The only subsystem left alive at this point is the
643         * memory allocator.
644         */
645    
646        while (firstPackagePtr != NULL) {
647            pkgPtr = firstPackagePtr;
648            firstPackagePtr = pkgPtr->nextPtr;
649    #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
650            /*
651             * Some Unix dlls are poorly behaved - registering things like
652             * atexit calls that can't be unregistered.  If you unload
653             * such dlls, you get a core on exit because it wants to
654             * call a function in the dll after it's been unloaded.
655             */
656            if (pkgPtr->fileName[0] != '\0') {
657                TclpUnloadFile(pkgPtr->clientData);
658            }
659    #endif
660            ckfree(pkgPtr->fileName);
661            ckfree(pkgPtr->packageName);
662            ckfree((char *) pkgPtr);
663        }
664    }
665    
666    /* End of tclload.c */

Legend:
Removed from v.25  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25