tclload.c

来自「tcl是工具命令语言」· C语言 代码 · 共 701 行 · 第 1/2 页

		(*unLoadProcPtr)(loadHandle);
	    }
	    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->loadHandle	= loadHandle;
	pkgPtr->unLoadProcPtr	= unLoadProcPtr;
	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(&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. */
    CONST 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 in the process.
     */

    Tcl_MutexLock(&packageMutex);
    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
	if ((pkgPtr->initProc == initProc)
		&& (pkgPtr->safeInitProc == safeInitProc)
		&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
	    break;
	}
    }
    Tcl_MutexUnlock(&packageMutex);

    /*
     * If the package is not yet recorded as being loaded statically,
     * add it to the list now.
     */

    if ( pkgPtr == 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->loadHandle	= NULL;
	pkgPtr->initProc	= initProc;
	pkgPtr->safeInitProc	= safeInitProc;
	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		= firstPackagePtr;
	firstPackagePtr		= pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
    }

    if (interp != NULL) {

	/*
	 * If we're loading the package into an interpreter,
	 * determine whether it's already loaded. 
	 */

	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
		(Tcl_InterpDeleteProc **) NULL);
	for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
	    if ( ipPtr->pkgPtr == pkgPtr ) {
		return;
	    }
	}

	/*
	 * Package isn't loade in the current interp yet. Mark it as
	 * now being loaded.
	 */

	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') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if (unLoadProcPtr != NULL) {
	        (*unLoadProcPtr)(pkgPtr->loadHandle);
	    }
	}
#endif
	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }
}