summaryrefslogtreecommitdiffstats
path: root/generic/tclLoad.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclLoad.c')
-rw-r--r--generic/tclLoad.c636
1 files changed, 636 insertions, 0 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
new file mode 100644
index 0000000..a1deee0
--- /dev/null
+++ b/generic/tclLoad.c
@@ -0,0 +1,636 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04
+ */
+
+#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);
+ }
+}
generated by cgit v0.12 at 2024-11-03 08:40:55 (GMT)