home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclLoad.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  17KB  |  601 lines
  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.10 96/04/02 18:44:22
  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 interpreter, with an AssocData value (key "load") for the
  60.  * interpreter that points to the first package (if any).
  61.  */
  62.  
  63. typedef struct InterpPackage {
  64.     LoadedPackage *pkgPtr;    /* Points to detailed information about
  65.                  * package. */
  66.     struct InterpPackage *nextPtr;
  67.                 /* Next package in this interpreter, or
  68.                  * NULL for end of list. */
  69. } InterpPackage;
  70.  
  71. /*
  72.  * Prototypes for procedures that are private to this file:
  73.  */
  74.  
  75. static void        LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
  76.                 Tcl_Interp *interp));
  77. static void        LoadExitProc _ANSI_ARGS_((ClientData clientData));
  78.  
  79. /*
  80.  *----------------------------------------------------------------------
  81.  *
  82.  * Tcl_LoadCmd --
  83.  *
  84.  *    This procedure is invoked to process the "load" Tcl command.
  85.  *    See the user documentation for details on what it does.
  86.  *
  87.  * Results:
  88.  *    A standard Tcl result.
  89.  *
  90.  * Side effects:
  91.  *    See the user documentation.
  92.  *
  93.  *----------------------------------------------------------------------
  94.  */
  95.  
  96. int
  97. Tcl_LoadCmd(dummy, interp, argc, argv)
  98.     ClientData dummy;            /* Not used. */
  99.     Tcl_Interp *interp;            /* Current interpreter. */
  100.     int argc;                /* Number of arguments. */
  101.     char **argv;            /* Argument strings. */
  102. {
  103.     Tcl_Interp *target;
  104.     LoadedPackage *pkgPtr;
  105.     Tcl_DString pkgName, initName, safeInitName, fileName;
  106.     Tcl_PackageInitProc *initProc, *safeInitProc;
  107.     InterpPackage *ipFirstPtr, *ipPtr;
  108.     int code, c, gotPkgName;
  109.     char *p, *fullFileName;
  110.  
  111.     if ((argc < 2) || (argc > 4)) {
  112.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  113.         " fileName ?packageName? ?interp?\"", (char *) NULL);
  114.     return TCL_ERROR;
  115.     }
  116.     fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName);
  117.     if (fullFileName == NULL) {
  118.     return TCL_ERROR;
  119.     }
  120.     Tcl_DStringInit(&pkgName);
  121.     Tcl_DStringInit(&initName);
  122.     Tcl_DStringInit(&safeInitName);
  123.     if ((argc >= 3) && (argv[2][0] != 0)) {
  124.     gotPkgName = 1;
  125.     } else {
  126.     gotPkgName = 0;
  127.     }
  128.     if ((fullFileName[0] == 0) && !gotPkgName) {
  129.     interp->result = "must specify either file name or package name";
  130.     code = TCL_ERROR;
  131.     goto done;
  132.     }
  133.  
  134.     /*
  135.      * Figure out which interpreter we're going to load the package into.
  136.      */
  137.  
  138.     target = interp;
  139.     if (argc == 4) {
  140.     target = Tcl_GetSlave(interp, argv[3]);
  141.     if (target == NULL) {
  142.         Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
  143.             argv[3], "\"", (char *) NULL);
  144.         return TCL_ERROR;
  145.     }
  146.     }
  147.  
  148.     /*
  149.      * See if the desired file is already loaded.  If so, its package
  150.      * name must agree with ours (if we have one).
  151.      */
  152.  
  153.     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
  154.     if (strcmp(pkgPtr->fileName, fullFileName) != 0) {
  155.         continue;
  156.     }
  157.     if (gotPkgName) {
  158.         char *p1, *p2;
  159.         for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) {
  160.         if ((isupper(*p1) ? tolower(*p1) : *p1)
  161.             != (isupper(*p2) ? tolower(*p2) : *p2)) {
  162.             if (fullFileName[0] == 0) {
  163.             /*
  164.              * We're looking for a statically loaded package;
  165.              * the file name is basically irrelevant here, so
  166.              * don't get upset that there's some other package
  167.              * with the same (empty string) file name.  Just
  168.              * skip this package and go on to the next.
  169.              */
  170.  
  171.             goto nextPackage;
  172.             }
  173.             Tcl_AppendResult(interp, "file \"", fullFileName,
  174.                 "\" is already loaded for package \"",
  175.                 pkgPtr->packageName, "\"", (char *) NULL);
  176.             code = TCL_ERROR;
  177.             goto done;
  178.         }
  179.         if (*p1 == 0) {
  180.             goto gotPkg;
  181.         }
  182.         }
  183.         nextPackage:
  184.         continue;
  185.     }
  186.     break;
  187.     }
  188.     gotPkg:
  189.  
  190.     /*
  191.      * If the file is already loaded in the target interpreter then
  192.      * there's nothing for us to do.
  193.      */
  194.  
  195.     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
  196.         (Tcl_InterpDeleteProc **) NULL);
  197.     if (pkgPtr != NULL) {
  198.     for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
  199.         if (ipPtr->pkgPtr == pkgPtr) {
  200.         code = TCL_OK;
  201.         goto done;
  202.         }
  203.     }
  204.     }
  205.  
  206.     if (pkgPtr == NULL) {
  207.     /*
  208.      * The desired file isn't currently loaded, so load it.  It's an
  209.      * error if the desired package is a static one.
  210.      */
  211.  
  212.     if (fullFileName[0] == 0) {
  213.         Tcl_AppendResult(interp, "package \"", argv[2],
  214.             "\" isn't loaded statically", (char *) NULL);
  215.         code = TCL_ERROR;
  216.         goto done;
  217.     }
  218.  
  219.     /*
  220.      * Figure out the module name if it wasn't provided explicitly.
  221.      */
  222.  
  223.     if (gotPkgName) {
  224.         Tcl_DStringAppend(&pkgName, argv[2], -1);
  225.     } else {
  226.         if (!TclGuessPackageName(fullFileName, &pkgName)) {
  227.         int pargc;
  228.         char **pargv, *pkgGuess;
  229.  
  230.         /*
  231.          * The platform-specific code couldn't figure out the
  232.          * module name.  Make a guess by taking the last element
  233.          * of the file name, stripping off any leading "lib", and
  234.          * then using all of the alphabetic characters that follow
  235.          * that.
  236.          */
  237.  
  238.         Tcl_SplitPath(fullFileName, &pargc, &pargv);
  239.         pkgGuess = pargv[pargc-1];
  240.         if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
  241.             && (pkgGuess[2] == 'b')) {
  242.             pkgGuess += 3;
  243.         }
  244.         for (p = pkgGuess; isalpha(*p); p++) {
  245.             /* Empty loop body. */
  246.         }
  247.         if (p == pkgGuess) {
  248.             ckfree((char *)pargv);
  249.             Tcl_AppendResult(interp,
  250.                 "couldn't figure out package name for ",
  251.                 fullFileName, (char *) NULL);
  252.             code = TCL_ERROR;
  253.             goto done;
  254.         }
  255.         Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
  256.         ckfree((char *)pargv);
  257.         }
  258.     }
  259.  
  260.     /*
  261.      * Fix the capitalization in the package name so that the first
  262.      * character is in caps but the others are all lower-case.
  263.      */
  264.     
  265.     p = Tcl_DStringValue(&pkgName);
  266.     c = UCHAR(*p);
  267.     if (c != 0) {
  268.         if (islower(c)) {
  269.         *p = (char) toupper(c);
  270.         }
  271.         p++;
  272.         while (1) {
  273.         c = UCHAR(*p);
  274.         if (c == 0) {
  275.             break;
  276.         }
  277.         if (isupper(c)) {
  278.             *p = (char) tolower(c);
  279.         }
  280.         p++;
  281.         }
  282.     }
  283.  
  284.     /*
  285.      * Compute the names of the two initialization procedures,
  286.      * based on the package name.
  287.      */
  288.     
  289.     Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
  290.     Tcl_DStringAppend(&initName, "_Init", 5);
  291.     Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
  292.     Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
  293.     
  294.     /*
  295.      * Call platform-specific code to load the package and find the
  296.      * two initialization procedures.
  297.      */
  298.     
  299.     code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
  300.         Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc);
  301.     if (code != TCL_OK) {
  302.         goto done;
  303.     }
  304.     if (initProc  == NULL) {
  305.         Tcl_AppendResult(interp, "couldn't find procedure ",
  306.             Tcl_DStringValue(&initName), (char *) NULL);
  307.         code = TCL_ERROR;
  308.         goto done;
  309.     }
  310.  
  311.     /*
  312.      * Create a new record to describe this package.
  313.      */
  314.  
  315.     if (firstPackagePtr == NULL) {
  316.         Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
  317.     }
  318.     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
  319.     pkgPtr->fileName = (char *) ckalloc((unsigned)
  320.         (strlen(fullFileName) + 1));
  321.     strcpy(pkgPtr->fileName, fullFileName);
  322.     pkgPtr->packageName = (char *) ckalloc((unsigned)
  323.         (Tcl_DStringLength(&pkgName) + 1));
  324.     strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
  325.     pkgPtr->initProc = initProc;
  326.     pkgPtr->safeInitProc = safeInitProc;
  327.     pkgPtr->nextPtr = firstPackagePtr;
  328.     firstPackagePtr = pkgPtr;
  329.     }
  330.  
  331.     /*
  332.      * Invoke the package's initialization procedure (either the
  333.      * normal one or the safe one, depending on whether or not the
  334.      * interpreter is safe).
  335.      */
  336.  
  337.     if (Tcl_IsSafe(target)) {
  338.     if (pkgPtr->safeInitProc != NULL) {
  339.         code = (*pkgPtr->safeInitProc)(target);
  340.     } else {
  341.         Tcl_AppendResult(interp,
  342.             "can't use package in a safe interpreter: ",
  343.             "no ", pkgPtr->packageName, "_SafeInit procedure",
  344.             (char *) NULL);
  345.         code = TCL_ERROR;
  346.         goto done;
  347.     }
  348.     } else {
  349.     code = (*pkgPtr->initProc)(target);
  350.     }
  351.     if ((code == TCL_ERROR) && (target != interp)) {
  352.     /*
  353.      * An error occurred, so transfer error information from the
  354.      * destination interpreter back to our interpreter.  Must clear
  355.      * interp's result before calling Tcl_AddErrorInfo, since
  356.      * Tcl_AddErrorInfo will store the interp's result in errorInfo
  357.      * before appending target's $errorInfo;  we've already got
  358.      * everything we need in target's $errorInfo.
  359.      */
  360.  
  361.     Tcl_ResetResult(interp);
  362.     Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
  363.         "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
  364.     Tcl_SetVar2(interp, "errorCode", (char *) NULL,
  365.         Tcl_GetVar2(target, "errorCode", (char *) NULL,
  366.         TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);
  367.     Tcl_SetResult(interp, target->result, TCL_VOLATILE);
  368.     }
  369.  
  370.     /*
  371.      * Record the fact that the package has been loaded in the
  372.      * target interpreter.
  373.      */
  374.  
  375.     if (code == TCL_OK) {
  376.     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
  377.     ipPtr->pkgPtr = pkgPtr;
  378.     ipPtr->nextPtr = ipFirstPtr;
  379.     Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
  380.         (ClientData) ipPtr);
  381.     }
  382.  
  383.     done:
  384.     Tcl_DStringFree(&pkgName);
  385.     Tcl_DStringFree(&initName);
  386.     Tcl_DStringFree(&safeInitName);
  387.     Tcl_DStringFree(&fileName);
  388.     return code;
  389. }
  390.  
  391. /*
  392.  *----------------------------------------------------------------------
  393.  *
  394.  * Tcl_StaticPackage --
  395.  *
  396.  *    This procedure is invoked to indicate that a particular
  397.  *    package has been linked statically with an application.
  398.  *
  399.  * Results:
  400.  *    None.
  401.  *
  402.  * Side effects:
  403.  *    Once this procedure completes, the package becomes loadable
  404.  *    via the "load" command with an empty file name.
  405.  *
  406.  *----------------------------------------------------------------------
  407.  */
  408.  
  409. void
  410. Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
  411.     Tcl_Interp *interp;            /* If not NULL, it means that the
  412.                      * package has already been loaded
  413.                      * into the given interpreter by
  414.                      * calling the appropriate init proc. */
  415.     char *pkgName;            /* Name of package (must be properly
  416.                      * capitalized: first letter upper
  417.                      * case, others lower case). */
  418.     Tcl_PackageInitProc *initProc;    /* Procedure to call to incorporate
  419.                      * this package into a trusted
  420.                      * interpreter. */
  421.     Tcl_PackageInitProc *safeInitProc;    /* Procedure to call to incorporate
  422.                      * this package into a safe interpreter
  423.                      * (one that will execute untrusted
  424.                      * scripts).   NULL means the package
  425.                      * can't be used in safe
  426.                      * interpreters. */
  427. {
  428.     LoadedPackage *pkgPtr;
  429.     InterpPackage *ipPtr, *ipFirstPtr;
  430.  
  431.     if (firstPackagePtr == NULL) {
  432.     Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
  433.     }
  434.     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
  435.     pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
  436.     pkgPtr->fileName[0] = 0;
  437.     pkgPtr->packageName = (char *) ckalloc((unsigned)
  438.         (strlen(pkgName) + 1));
  439.     strcpy(pkgPtr->packageName, pkgName);
  440.     pkgPtr->initProc = initProc;
  441.     pkgPtr->safeInitProc = safeInitProc;
  442.     pkgPtr->nextPtr = firstPackagePtr;
  443.     firstPackagePtr = pkgPtr;
  444.  
  445.     if (interp != NULL) {
  446.     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
  447.         (Tcl_InterpDeleteProc **) NULL);
  448.     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
  449.     ipPtr->pkgPtr = pkgPtr;
  450.     ipPtr->nextPtr = ipFirstPtr;
  451.     Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
  452.         (ClientData) ipPtr);
  453.     }
  454. }
  455.  
  456. /*
  457.  *----------------------------------------------------------------------
  458.  *
  459.  * TclGetLoadedPackages --
  460.  *
  461.  *    This procedure returns information about all of the files
  462.  *    that are loaded (either in a particular intepreter, or
  463.  *    for all interpreters).
  464.  *
  465.  * Results:
  466.  *    The return value is a standard Tcl completion code.  If
  467.  *    successful, a list of lists is placed in interp->result.
  468.  *    Each sublist corresponds to one loaded file;  its first
  469.  *    element is the name of the file (or an empty string for
  470.  *    something that's statically loaded) and the second element
  471.  *    is the name of the package in that file.
  472.  *
  473.  * Side effects:
  474.  *    None.
  475.  *
  476.  *----------------------------------------------------------------------
  477.  */
  478.  
  479. int
  480. TclGetLoadedPackages(interp, targetName)
  481.     Tcl_Interp *interp;        /* Interpreter in which to return
  482.                  * information or error message. */
  483.     char *targetName;        /* Name of target interpreter or NULL.
  484.                  * If NULL, return info about all interps;
  485.                  * otherwise, just return info about this
  486.                  * interpreter. */
  487. {
  488.     Tcl_Interp *target;
  489.     LoadedPackage *pkgPtr;
  490.     InterpPackage *ipPtr;
  491.     char *prefix;
  492.  
  493.     if (targetName == NULL) {
  494.     /* 
  495.      * Return information about all of the available packages.
  496.      */
  497.  
  498.     prefix = "{";
  499.     for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
  500.         pkgPtr = pkgPtr->nextPtr) {
  501.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  502.         Tcl_AppendElement(interp, pkgPtr->fileName);
  503.         Tcl_AppendElement(interp, pkgPtr->packageName);
  504.         Tcl_AppendResult(interp, "}", (char *) NULL);
  505.         prefix = " {";
  506.     }
  507.     return TCL_OK;
  508.     }
  509.  
  510.     /*
  511.      * Return information about only the packages that are loaded in
  512.      * a given interpreter.
  513.      */
  514.  
  515.     target = Tcl_GetSlave(interp, targetName);
  516.     if (target == NULL) {
  517.     Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
  518.         targetName, "\"", (char *) NULL);
  519.     return TCL_ERROR;
  520.     }
  521.     ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
  522.         (Tcl_InterpDeleteProc **) NULL);
  523.     prefix = "{";
  524.     for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
  525.     pkgPtr = ipPtr->pkgPtr;
  526.     Tcl_AppendResult(interp, prefix, (char *) NULL);
  527.     Tcl_AppendElement(interp, pkgPtr->fileName);
  528.     Tcl_AppendElement(interp, pkgPtr->packageName);
  529.     Tcl_AppendResult(interp, "}", (char *) NULL);
  530.     prefix = " {";
  531.     }
  532.     return TCL_OK;
  533. }
  534.  
  535. /*
  536.  *----------------------------------------------------------------------
  537.  *
  538.  * LoadCleanupProc --
  539.  *
  540.  *    This procedure is called to delete all of the InterpPackage
  541.  *    structures for an interpreter when the interpreter is deleted.
  542.  *    It gets invoked via the Tcl AssocData mechanism.
  543.  *
  544.  * Results:
  545.  *    None.
  546.  *
  547.  * Side effects:
  548.  *    Storage for all of the InterpPackage procedures for interp
  549.  *    get deleted.
  550.  *
  551.  *----------------------------------------------------------------------
  552.  */
  553.  
  554. static void
  555. LoadCleanupProc(clientData, interp)
  556.     ClientData clientData;    /* Pointer to first InterpPackage structure
  557.                  * for interp. */
  558.     Tcl_Interp *interp;        /* Interpreter that is being deleted. */
  559. {
  560.     InterpPackage *ipPtr, *nextPtr;
  561.  
  562.     ipPtr = (InterpPackage *) clientData;
  563.     while (ipPtr != NULL) {
  564.     nextPtr = ipPtr->nextPtr;
  565.     ckfree((char *) ipPtr);
  566.     ipPtr = nextPtr;
  567.     }
  568. }
  569.  
  570. /*
  571.  *----------------------------------------------------------------------
  572.  *
  573.  * LoadExitProc --
  574.  *
  575.  *    This procedure is invoked just before the application exits.
  576.  *    It frees all of the LoadedPackage structures.
  577.  *
  578.  * Results:
  579.  *    None.
  580.  *
  581.  * Side effects:
  582.  *    Memory is freed.
  583.  *
  584.  *----------------------------------------------------------------------
  585.  */
  586.  
  587. static void
  588. LoadExitProc(clientData)
  589.     ClientData clientData;        /* Not used. */
  590. {
  591.     LoadedPackage *pkgPtr;
  592.  
  593.     while (firstPackagePtr != NULL) {
  594.     pkgPtr = firstPackagePtr;
  595.     firstPackagePtr = pkgPtr->nextPtr;
  596.     ckfree(pkgPtr->fileName);
  597.     ckfree(pkgPtr->packageName);
  598.     ckfree((char *) pkgPtr);
  599.     }
  600. }
  601.