home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclLoad.c < prev    next >
Encoding:
Text File  |  1997-08-15  |  18.0 KB  |  494 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclLoad.c --
  3.  *
  4.  *    This file provides the generic portion (those that are the same
  5.  *    on all platforms) of Tcl's dynamic loading facilities.
  6.  *
  7.  * Copyright (c) 1995 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04
  13.  */
  14.  
  15. #include "tclInt.h"
  16.  
  17. /*
  18.  * The following structure describes a package that has been loaded
  19.  * either dynamically (with the "load" command) or statically (as
  20.  * indicated by a call to Tcl_PackageLoaded).  All such packages
  21.  * are linked together into a single list for the process.  Packages
  22.  * are never unloaded, so these structures are never freed.
  23.  */
  24.  
  25. typedef struct LoadedPackage {
  26.     char *fileName;        /* Name of the file from which the
  27.                  * package was loaded.  An empty string
  28.                  * means the package is loaded statically.
  29.                  * 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_PackageInitProc *initProc;
  35.                 /* Initialization procedure to call to
  36.                  * incorporate this package into a trusted
  37.                  * interpreter. */
  38.     Tcl_PackageInitProc *safeInitProc;
  39.                 /* Initialization procedure to call to
  40.                  * incorporate this package into a safe
  41.                  * interpreter (one that will execute
  42.                  * untrusted scripts).   NULL means the
  43.                  * package can't be used in unsafe
  44.                  * interpreters. */
  45.     struct LoadedPackage *nextPtr;
  46.                 /* Next in list of all packages loaded into
  47.                  * this application process.  NULL means
  48.                  * end of list. */
  49. } LoadedPackage;
  50.  
  51. static LoadedPackage *firstPackagePtr = NULL;
  52.                 /* First in list of all packages loaded into
  53.                  * this process. */
  54.  
  55. /*
  56.  * The following structure represents a particular package that has
  57.  * been incorporated into a particular interpreter (by calling its
  58.  * initialization procedure).  There is a list of these structures for
  59.  * each if packages already loaded in the target
  60.      * interpreter.  If the package we want is already loaded there,
  61.      * then there's nothing for us to to.
  62.      */
  63.  
  64.     if (pkgPtr != NULL) {
  65.     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
  66.         (Tcl_InterpDeleteProc **) NULL);
  67.     for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
  68.         if (ipPtr->pkgPtr == pkgPtr) {
  69.         code = TCL_OK;
  70.         goto done;
  71.         }
  72.     }
  73.     }
  74.  
  75.     if (pkgPtr == NULL) {
  76.     /*
  77.      * The desired file isn't currently loaded, so load it.  It's an
  78.      * error if the desired package is a static one.
  79.      */
  80.  
  81.     if (fullFileName[0] == 0) {
  82.         Tcl_AppendResult(interp, "package \"", argv[2],
  83.             "\" isn't loaded statically", (char *) NULL);
  84.         code = TCL_ERROR;
  85.         goto done;
  86.     }
  87.  
  88.     /*
  89.      * Figure out the module name if it wasn't provided explicitly.
  90.      */
  91.  
  92.     if (gotPkgName) {
  93.         Tcl_DStringAppend(&pkgName, argv[2], -1);
  94.     } else {
  95.         if (!TclGuessPackageName(fullFileName, &pkgName)) {
  96.         int pargc;
  97.         char **pargv, *pkgGuess;
  98.  
  99.         /*
  100.          * The platform-specific code couldn't figure out the
  101.          * module name.  Make a guess by taking the last element
  102.          * of the file name, stripping off any leading "lib",
  103.          * and then using all of the alphabetic and underline
  104.          * characters that follow that.
  105.          */
  106.  
  107.         Tcl_SplitPath(fullFileName, &pargc, &pargv);
  108.         pkgGuess = pargv[pargc-1];
  109.         if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
  110.             && (pkgGuess[2] == 'b')) {
  111.             pkgGuess += 3;
  112.         }
  113.         for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) {
  114.             /* Empty loop body. */
  115.         }
  116.         if (p == pkgGuess) {
  117.             ckfree((char *)pargv);
  118.             Tcl_AppendResult(interp,
  119.                 "couldn't figure out package name for ",
  120.                 fullFileName, (char *) NULL);
  121.             code = TCL_ERROR;
  122.             goto done;
  123.         }
  124.         Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
  125.         ckfree((char *)pargv);
  126.         }
  127.     }
  128.  
  129.     /*
  130.      * Fix the capitalization in the package name so that the first
  131.      * character is in caps but the others are all lower-case.
  132.      */
  133.     
  134.     p = Tcl_DStringValue(&pkgName);
  135.     c = UCHAR(*p);
  136.     if (c != 0) {
  137.         if (islower(c)) {
  138.         *p = (char) toupper(c);
  139.         }
  140.         p++;
  141.         while (1) {
  142.         c = UCHAR(*p);
  143.         if (c == 0) {
  144.             break;
  145.         }
  146.         if (isupper(c)) {
  147.             *p = (char) tolower(c);
  148.         }
  149.         p++;
  150.         }
  151.     }
  152.  
  153.     /*
  154.      * Compute the names of the two initialization procedures,
  155.      * based on the package name.
  156.      */
  157.     
  158.     Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
  159.     Tcl_DStringAppend(&initName, "_Init", 5);
  160.     Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
  161.     Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
  162.     
  163.     /*
  164.      * Call platform-specific code to load the package and find the
  165.      * two initialization procedures.
  166.      */
  167.     
  168.     code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
  169.         Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc);
  170.     if (code != TCL_OK) {
  171.         goto done;
  172.     }
  173.     if (initProc  == NULL) {
  174.         Tcl_AppendResult(interp, "couldn't find procedure ",
  175.             Tcl_DStringValue(&initName), (char *) NULL);
  176.         code = TCL_ERROR;
  177.         goto done;
  178.     }
  179.  
  180.     /*
  181.      * Create a new record to describe this package.
  182.      */
  183.  
  184.     if (firstPackagePtr == NULL) {
  185.         Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
  186.     }
  187.     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
  188.     pkgPtr->fileName = (char *) ckalloc((unsigned)
  189.         (strlen(fullFileName) + 1));
  190.     strcpy(pkgPtr->fileName, fullFileName);
  191.     pkgPtr->packageName = (char *) ckalloc((unsigned)
  192.         (Tcl_DStringLength(&pkgName) + 1));
  193.     strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
  194.     pkgPtr->initProc = initProc;
  195.     pkgPtr->safeInitProc = safeInitProc;
  196.     pkgPtr->nextPtr = firstPackagePtr;
  197.     firstPackagePtr = pkgPtr;
  198.     }
  199.  
  200.     /*
  201.      * Invoke the package's initialization procedure (either the
  202.      * normal one or the safe one, depending on whether or not the
  203.      * interpreter is safe).
  204.      */
  205.  
  206.     if (Tcl_IsSafe(target)) {
  207.     if (pkgPtr->safeInitProc != NULL) {
  208.         code = (*pkgPtr->safeInitProc)(target);
  209.     } else {
  210.         Tcl_AppendResult(interp,
  211.             "can't use package in a safe interpreter: ",
  212.             "no ", pkgPtr->packageName, "_SafeInit procedure",
  213.             (char *) NULL);
  214.         code = TCL_ERROR;
  215.         goto done;
  216.     }
  217.     } else {
  218.     code = (*pkgPtr->initProc)(target);
  219.     }
  220.     if ((code == TCL_ERROR) && (target != interp)) {
  221.     /*
  222.      * An error occurred, so transfer error information from the
  223.      * destination interpreter back to our interpreter.  Must clear
  224.      * interp's result before calling Tcl_AddErrorInfo, since
  225.      * Tcl_AddErrorInfo will store the interp's result in errorInfo
  226.      * before appending target's $errorInfo;  we've already got
  227.      * everything we need in target's $errorInfo.
  228.      */
  229.  
  230.     /*
  231.          * It is (abusively) assumed that errorInfo and errorCode vars exists.
  232.          * we changed SetVar2 to accept NULL values to avoid crashes. --dl
  233.      */
  234.     Tcl_ResetResult(interp);
  235.     Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
  236.         "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
  237.     Tcl_SetVar2(interp, "errorCode", (char *) NULL,
  238.         Tcl_GetVar2(target, "errorCode", (char *) NULL,
  239.         TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);
  240.     Tcl_SetResult(interp, target->result, TCL_VOLATILE);
  241.     }
  242.  
  243.     /*
  244.      * Record the fact that the package has been loaded in the
  245.      * target interpreter.
  246.      */
  247.  
  248.     if (code == TCL_OK) {
  249.     /*
  250.      * Refetch ipFirstPtr: loading the package may have introduced
  251.      * additional static packages at the head of the linked list!
  252.      */
  253.  
  254.     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
  255.         (Tcl_InterpDeleteProc **) NULL);
  256.     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
  257.     ipPtr->pkgPtr = pkgPtr;
  258.     ipPtr->nextPtr = ipFirstPtr;
  259.     Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
  260.         (ClientData) ipPtr);
  261.     }
  262.  
  263.     done:
  264.     Tcl_DStringFree(&pkgName);
  265.     Tcl_DStringFree(&initName);
  266.     Tcl_DStringFree(&safeInitName);
  267.     Tcl_DStringFree(&fileName);
  268.     return code;
  269. }
  270.  
  271. /*
  272.  *----------------------------------------------------------------------
  273.  *
  274.  * Tcl_StaticPackage --
  275.  *
  276.  *    This procedure is invoked to indicate that a particular
  277.  *    package has been linked statically with an application.
  278.  *
  279.  * Results:
  280.  *    None.
  281.  *
  282.  * Side effects:
  283.  *    Once this procedure completes, the package becomes loadable
  284.  *    via the "load" command with an empty file name.
  285.  *
  286.  *----------------------------------------------------------------------
  287.  */
  288.  
  289. void
  290. Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
  291.     Tcl_Interp *interp;            /* If not NULL, it means that the
  292.                      * package has already been loaded
  293.                      * into the given interpreter by
  294.                      * calling the appropriate init proc. */
  295.     char *pkgName;            /* Name of package (must be properly
  296.                      * capitalized: first letter upper
  297.                      * case, others lower case). */
  298.     Tcl_PackageInitProc *initProc;    /* Procedure to call to incorporate
  299.                      * this package into a trusted
  300.                      * interpreter. */
  301.     Tcl_PackageInitProc *safeInitProc;    /* Procedure to call to incorporate
  302.                      * this package into a safe interpreter
  303.                      * (one that will execute untrusted
  304.                      * scripts).   NULL means the package
  305.                      * can't be used in safe
  306.                      * interpreters. */
  307. {
  308.     LoadedPackage *pkgPtr;
  309.     InterpPackage *ipPtr, *ipFirstPtr;
  310.  
  311.     /*
  312.      * Check to see if someone else has already reported this package as
  313.      * statically loaded.  If this call is redundant then just return.
  314.      */
  315.  
  316.     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
  317.     if ((pkgPtr->initProc == initProc)
  318.         && (pkgPtr->safeInitProc == safeInitProc)
  319.         && (strcmp(pkgPtr->packageName, pkgName) == 0)) {
  320.         return;
  321.     }
  322.     }
  323.  
  324.     if (firstPackagePtr == NULL) {
  325.     Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
  326.     }
  327.     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
  328.     pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
  329.     pkgPtr->fileName[0] = 0;
  330.     pkgPtr->packageName = (char *) ckalloc((unsigned)
  331.         (strlen(pkgName) + 1));
  332.     strcpy(pkgPtr->packageName, pkgName);
  333.     pkgPtr->initProc = initProc;
  334.     pkgPtr->safeInitProc = safeInitProc;
  335.     pkgPtr->nextPtr = firstPackagePtr;
  336.     firstPackagePtr = pkgPtr;
  337.  
  338.     if (interp != NULL) {
  339.     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
  340.         (Tcl_InterpDeleteProc **) NULL);
  341.     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
  342.     ipPtr->pkgPtr = pkgPtr;
  343.     ipPtr->nextPtr = ipFirstPtr;
  344.     Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
  345.         (ClientData) ipPtr);
  346.     }
  347. }
  348.  
  349. /*
  350.  *----------------------------------------------------------------------
  351.  *
  352.  * TclGetLoadedPackages --
  353.  *
  354.  *    This procedure returns information about all of the files
  355.  *    that are loaded (either in a particular intepreter, or
  356.  *    for all interpreters).
  357.  *
  358.  * Results:
  359.  *    The return value is a standard Tcl completion code.  If
  360.  *    successful, a list of lists is placed in interp->result.
  361.  *    Each sublist corresponds to one loaded file;  its first
  362.  *    element is the name of the file (or an empty string for
  363.  *    something that's statically loaded) and the second element
  364.  *    is the name of the package in that file.
  365.  *
  366.  * Side effects:
  367.  *    None.
  368.  *
  369.  *----------------------------------------------------------------------
  370.  */
  371.  
  372. int
  373. TclGetLoadedPackages(interp, targetName)
  374.     Tcl_Interp *interp;        /* Interpreter in which to return
  375.                  * information or error message. */
  376.     char *targetName;        /* Name of target interpreter or NULL.
  377.                  * If NULL, return info about all interps;
  378.                  * otherwise, just return info about this
  379.                  * interpreter. */
  380. {
  381.     Tcl_Interp *target;
  382.     LoadedPackage *pkgPtr;
  383.     InterpPackage *ipPtr;
  384.     char *prefix;
  385.  
  386.     if (targetName == NULL) {
  387.     /* 
  388.      * Return information about all of the available packages.
  389.      */
  390.  
  391.     prefix = "{";
  392.     for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
  393.         pkgPtr = pkgPtr->nextPtr) {
  394.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  395.         Tcl_AppendElement(interp, pkgPtr->fileName);
  396.         Tcl_AppendElement(interp, pkgPtr->packageName);
  397.         Tcl_AppendResult(interp, "}", (char *) NULL);
  398.         prefix = " {";
  399.     }
  400.     return TCL_OK;
  401.     }
  402.  
  403.     /*
  404.      * Return information about only the packages that are loaded in
  405.      * a given interpreter.
  406.      */
  407.  
  408.     target = Tcl_GetSlave(interp, targetName);
  409.     if (target == NULL) {
  410.     Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
  411.         targetName, "\"", (char *) NULL);
  412.     return TCL_ERROR;
  413.     }
  414.     ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
  415.         (Tcl_InterpDeleteProc **) NULL);
  416.     prefix = "{";
  417.     for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
  418.     pkgPtr = ipPtr->pkgPtr;
  419.     Tcl_AppendResult(interp, prefix, (char *) NULL);
  420.     Tcl_AppendElement(interp, pkgPtr->fileName);
  421.     Tcl_AppendElement(interp, pkgPtr->packageName);
  422.     Tcl_AppendResult(interp, "}", (char *) NULL);
  423.     prefix = " {";
  424.     }
  425.     return TCL_OK;
  426. }
  427.  
  428. /*
  429.  *----------------------------------------------------------------------
  430.  *
  431.  * LoadCleanupProc --
  432.  *
  433.  *    This procedure is called to delete all of the InterpPackage
  434.  *    structures for an interpreter when the interpreter is deleted.
  435.  *    It gets invoked via the Tcl AssocData mechanism.
  436.  *
  437.  * Results:
  438.  *    None.
  439.  *
  440.  * Side effects:
  441.  *    Storage for all of the InterpPackage procedures for interp
  442.  *    get deleted.
  443.  *
  444.  *----------------------------------------------------------------------
  445.  */
  446.  
  447. static void
  448. LoadCleanupProc(clientData, interp)
  449.     ClientData clientData;    /* Pointer to first InterpPackage structure
  450.                  * for interp. */
  451.     Tcl_Interp *interp;        /* Interpreter that is being deleted. */
  452. {
  453.     InterpPackage *ipPtr, *nextPtr;
  454.  
  455.     ipPtr = (InterpPackage *) clientData;
  456.     while (ipPtr != NULL) {
  457.     nextPtr = ipPtr->nextPtr;
  458.     ckfree((char *) ipPtr);
  459.     ipPtr = nextPtr;
  460.     }
  461. }
  462.  
  463. /*
  464.  *----------------------------------------------------------------------
  465.  *
  466.  * LoadExitProc --
  467.  *
  468.  *    This procedure is invoked just before the application exits.
  469.  *    It frees all of the LoadedPackage structures.
  470.  *
  471.  * Results:
  472.  *    None.
  473.  *
  474.  * Side effects:
  475.  *    Memory is freed.
  476.  *
  477.  *----------------------------------------------------------------------
  478.  */
  479.  
  480. static void
  481. LoadExitProc(clientData)
  482.     ClientData clientData;        /* Not used. */
  483. {
  484.     LoadedPackage *pkgPtr;
  485.  
  486.     while (firstPackagePtr != NULL) {
  487.     pkgPtr = firstPackagePtr;
  488.     firstPackagePtr = pkgPtr->nextPtr;
  489.     ckfree(pkgPtr->fileName);
  490.     ckfree(pkgPtr->packageName);
  491.     ckfree((char *) pkgPtr);
  492.     }
  493. }
  494.