Subversion Repositories or1k_old

/*

 * 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 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 2002-01-16 10:25:28 markom 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 Tcl_PackageLoaded).  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. */

    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;

static LoadedPackage *firstPackagePtr = NULL;

                                /* First in list of all packages loaded into

                                 * this process. */

/*

 * 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));

static void             LoadExitProc _ANSI_ARGS_((ClientData clientData));

/*

 *----------------------------------------------------------------------

 *

 * Tcl_LoadCmd --

 *

 *      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_LoadCmd(dummy, interp, argc, argv)

    ClientData dummy;                   /* Not used. */

    Tcl_Interp *interp;                 /* Current interpreter. */

    int argc;                           /* Number of arguments. */

    char **argv;                        /* Argument strings. */

{

    Tcl_Interp *target;

    LoadedPackage *pkgPtr, *defaultPtr;

    Tcl_DString pkgName, initName, safeInitName, fileName;

    Tcl_PackageInitProc *initProc, *safeInitProc;

    InterpPackage *ipFirstPtr, *ipPtr;

    int code, c, gotPkgName, namesMatch, filesMatch;

    char *p, *fullFileName, *p1, *p2;

    if ((argc < 2) || (argc > 4)) {

        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                " fileName ?packageName? ?interp?\"", (char *) NULL);

        return TCL_ERROR;

    }

    fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName);

    if (fullFileName == NULL) {

        return TCL_ERROR;

    }

    Tcl_DStringInit(&pkgName);

    Tcl_DStringInit(&initName);

    Tcl_DStringInit(&safeInitName);

    if ((argc >= 3) && (argv[2][0] != 0)) {

        gotPkgName = 1;

    } else {

        gotPkgName = 0;

    }

    if ((fullFileName[0] == 0) && !gotPkgName) {

        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 (argc == 4) {

        target = Tcl_GetSlave(interp, argv[3]);

        if (target == NULL) {

            Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",

                    argv[3], "\"", (char *) 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.

     */

    defaultPtr = NULL;

    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {

        if (!gotPkgName) {

            namesMatch = 0;

        } else {

            namesMatch = 1;

            for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) {

                if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1)

                        != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) {

                    namesMatch = 0;

                    break;

                }

                if (*p1 == 0) {

                    break;

                }

            }

        }

        filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);

        if (filesMatch && (namesMatch || !gotPkgName)) {

            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;

            goto done;

        }

    }

    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 \"", argv[2],

                    "\" isn't loaded statically", (char *) NULL);

            code = TCL_ERROR;

            goto done;

        }

        /*

         * Figure out the module name if it wasn't provided explicitly.

         */

        if (gotPkgName) {

            Tcl_DStringAppend(&pkgName, argv[2], -1);

        } else {

            if (!TclGuessPackageName(fullFileName, &pkgName)) {

                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; isalpha(UCHAR(*p)) || (*p == '_'); p++) {

                    /* Empty loop body. */

                }

                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 but the others are all lower-case.

         */

        p = Tcl_DStringValue(&pkgName);

        c = UCHAR(*p);

        if (c != 0) {

            if (islower(c)) {

                *p = (char) toupper(c);

            }

            p++;

            while (1) {

                c = UCHAR(*p);

                if (c == 0) {

                    break;

                }

                if (isupper(c)) {

                    *p = (char) tolower(c);

                }

                p++;

            }

        }

        /*

         * 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.

         */

        code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),

                Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc);

        if (code != TCL_OK) {

            goto done;

        }

        if (initProc  == NULL) {

            Tcl_AppendResult(interp, "couldn't find procedure ",

                    Tcl_DStringValue(&initName), (char *) NULL);

            code = TCL_ERROR;

            goto done;

        }

        /*

         * Create a new record to describe this package.

         */

        if (firstPackagePtr == NULL) {

            Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);

        }

        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->initProc = initProc;

        pkgPtr->safeInitProc = safeInitProc;

        pkgPtr->nextPtr = firstPackagePtr;

        firstPackagePtr = pkgPtr;

    }

    /*

     * 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);

    }

    if ((code == TCL_ERROR) && (target != interp)) {

        /*

         * An error occurred, so transfer error information from the

         * destination interpreter back to our interpreter.  Must clear

         * interp's result before calling Tcl_AddErrorInfo, since

         * Tcl_AddErrorInfo will store the interp's result in errorInfo

         * before appending target's $errorInfo;  we've already got

         * everything we need in target's $errorInfo.

         */

        /*

         * It is (abusively) assumed that errorInfo and errorCode vars exists.

         * we changed SetVar2 to accept NULL values to avoid crashes. --dl

         */

        Tcl_ResetResult(interp);

        Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,

                "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));

        Tcl_SetVar2(interp, "errorCode", (char *) NULL,

                Tcl_GetVar2(target, "errorCode", (char *) NULL,

                TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);

        Tcl_SetResult(interp, target->result, TCL_VOLATILE);

    }

    /*

     * 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);

    }

    done:

    Tcl_DStringFree(&pkgName);

    Tcl_DStringFree(&initName);

    Tcl_DStringFree(&safeInitName);

    Tcl_DStringFree(&fileName);

    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.

     */

    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {

        if ((pkgPtr->initProc == initProc)

                && (pkgPtr->safeInitProc == safeInitProc)

                && (strcmp(pkgPtr->packageName, pkgName) == 0)) {

            return;

        }

    }

    if (firstPackagePtr == NULL) {

        Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);

    }

    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->initProc = initProc;

    pkgPtr->safeInitProc = safeInitProc;

    pkgPtr->nextPtr = firstPackagePtr;

    firstPackagePtr = pkgPtr;

    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 interp->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 = "{";

        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 = " {";

        }

        return TCL_OK;

    }

    /*

     * Return information about only the packages that are loaded in

     * a given interpreter.

     */

    target = Tcl_GetSlave(interp, targetName);

    if (target == NULL) {

        Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",

                targetName, "\"", (char *) 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;

    }

}

/*

 *----------------------------------------------------------------------

 *

 * LoadExitProc --

 *

 *      This procedure is invoked just before the application exits.

 *      It frees all of the LoadedPackage structures.

 *

 * Results:

 *      None.

 *

 * Side effects:

 *      Memory is freed.

 *

 *----------------------------------------------------------------------

 */

static void

LoadExitProc(clientData)

    ClientData clientData;              /* Not used. */

{

    LoadedPackage *pkgPtr;

    while (firstPackagePtr != NULL) {

        pkgPtr = firstPackagePtr;

        firstPackagePtr = pkgPtr->nextPtr;

        ckfree(pkgPtr->fileName);

        ckfree(pkgPtr->packageName);

        ckfree((char *) pkgPtr);

    }

}