Tcl Source Code

/*
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same on all
 *	platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright © 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"


/*
 * The following structure describes a library that has been loaded either
 * dynamically (with the "load" command) or statically (as indicated by a call
 * to Tcl_StaticLibrary). All such libraries are linked together into a
 * single list for the process. Library are never unloaded, until the
 * application exits, when TclFinalizeLoad is called, and these structures are

				 * for end of list. */
} InterpLibrary;

/*
 * Prototypes for functions that are private to this file:
 */

static void	LoadCleanupProc(ClientData clientData,
		    Tcl_Interp *interp);
static int	IsStatic (LoadedLibrary *libraryPtr);
static int	UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
		    LoadedLibrary *library, int keepLibrary,
		    const char *fullFileName, int interpExiting);


static int
IsStatic (LoadedLibrary *libraryPtr) {
    int res;
    res = (libraryPtr->fileName[0] == '\0');
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LoadObjCmd --
 *
 *	This function is invoked to process the "load" Tcl command. See the

Tcl_UnloadObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;		/* Which interpreter to unload from. */
    LoadedLibrary *libraryPtr;
    Tcl_DString pfx, tmp;

    InterpLibrary *ipFirstPtr, *ipPtr;
    int i, index, code, complain = 1, keepLibrary = 0;

    const char *fullFileName = "";
    const char *prefix;
    static const char *const options[] = {
	"-nocomplain", "-keeplibrary", "--", NULL
    };
    enum unloadOptionsEnum {
	UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST

    /*
     * Scan through the libraries that are currently loaded to see if the
     * library we want is already loaded. We'll use a loaded library if it
     * meets any of the following conditions:
     *  - Its prefix and file match the once we're looking for.
     *  - Its file matches, and we weren't given a prefix.
     *  - Its prefix matches, the file name was specified as empty, and there is
     *	  no statically loaded library with the same prefix.
     */

    Tcl_MutexLock(&libraryMutex);


    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	int namesMatch, filesMatch;

	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);

	}
	TclDStringClear(&pfx);

	filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
	if (filesMatch && (namesMatch || (prefix == NULL))) {
	    break;
	}



	if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
	    break;
	}
    }
    Tcl_MutexUnlock(&libraryMutex);
    if (fullFileName[0] == 0) {
	/*

		fullFileName));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
		NULL);
	code = TCL_ERROR;
	goto done;
    }

    code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);

  done:
    Tcl_DStringFree(&pfx);
    Tcl_DStringFree(&tmp);
    if (!complain && (code != TCL_OK)) {
	code = TCL_OK;
	Tcl_ResetResult(interp);
    }
    return code;
}

static int
UnloadLibrary(
	Tcl_Interp *interp,
	Tcl_Interp *target,
	LoadedLibrary *libraryPtr,
	int keepLibrary,
	const char *fullFileName,
	int interpExiting
)
{
    int code;
    InterpLibrary *ipFirstPtr, *ipPtr;
    LoadedLibrary *iterLibraryPtr;
    int trustedRefCount = -1, safeRefCount = -1;
    Tcl_LibraryUnloadProc *unloadProc = NULL;

    /*
     * Ensure that the DLL can be unloaded. If it is a trusted interpreter,
     * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If
     * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL.
     */

    if (Tcl_IsSafe(target)) {
	if (libraryPtr->safeUnloadProc == NULL) {
	    if (!interpExiting) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"file \"%s\" cannot be unloaded under a safe interpreter",
			fullFileName));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
			NULL);
		code = TCL_ERROR;
		goto done;
	    }
	}
	unloadProc = libraryPtr->safeUnloadProc;
    } else {
	if (libraryPtr->unloadProc == NULL) {
	    if (!interpExiting) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"file \"%s\" cannot be unloaded under a trusted interpreter",
			fullFileName));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
			NULL);
		code = TCL_ERROR;
		goto done;
	    }
	}
	unloadProc = libraryPtr->unloadProc;
    }



    /*
     * We are ready to unload the library. First, evaluate the unload
     * function. If this fails, we cannot proceed with unload. Also, we must
     * specify the proper flag to pass to the unload callback.
     * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
     * only remove itself from the interpreter; the library will be unloaded
     * in a future call of unload. In case the library will be unloaded just
     * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
     */

    if (unloadProc == NULL) {
	code = TCL_OK;
    } else {
	code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
	if (!keepLibrary) {
	    Tcl_MutexLock(&libraryMutex);
	    trustedRefCount = libraryPtr->interpRefCount;
	    safeRefCount = libraryPtr->safeInterpRefCount;
	    Tcl_MutexUnlock(&libraryMutex);

	    if (Tcl_IsSafe(target)) {
		safeRefCount--;
	    } else {
		trustedRefCount--;
	    }

	    if (safeRefCount <= 0 && trustedRefCount <= 0) {
		code = TCL_UNLOAD_DETACH_FROM_PROCESS;
	    }
	}
	code = unloadProc(target, code);
    }


    if (code != TCL_OK) {
	Tcl_TransferResult(target, code, interp);
	goto done;
    }


    /*

		ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->libraryPtr == libraryPtr) {
		ipPrevPtr->nextPtr = ipPtr->nextPtr;
		break;
	    }
	}
    }
    ckfree(ipPtr);
    Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);


    if (IsStatic(libraryPtr)) {
	goto done;
    }

    /*
     * The unload function executed fine. Examine the reference count to see
     * if we unload the DLL.
     */


    Tcl_MutexLock(&libraryMutex);
    if (Tcl_IsSafe(target)) {
	libraryPtr->safeInterpRefCount--;

	/*
	 * Do not let counter get negative.

	/*
	 * 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 (!IsStatic(libraryPtr)) {
	    Tcl_MutexLock(&libraryMutex);
	    if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) {
		/*
		 * Remove this library from the loaded library cache.
		 */

		iterLibraryPtr = libraryPtr;
		if (iterLibraryPtr == firstLibraryPtr) {
		    firstLibraryPtr = libraryPtr->nextPtr;
		} else {
		    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
			    libraryPtr = libraryPtr->nextPtr) {
			if (libraryPtr->nextPtr == iterLibraryPtr) {
			    libraryPtr->nextPtr = iterLibraryPtr->nextPtr;
			    break;
			}
		    }
		}

		ckfree(iterLibraryPtr->fileName);
		ckfree(iterLibraryPtr->prefix);

		ckfree(iterLibraryPtr);
		Tcl_MutexUnlock(&libraryMutex);
	    } else {
		code = TCL_ERROR;
	    }
	}
#else
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"file \"%s\" cannot be unloaded: unloading disabled",
		fullFileName));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
		NULL);
	code = TCL_ERROR;
#endif
    }

  done:






    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StaticLibrary --

	libraryPtr->fileName	= (char *)ckalloc(1);
	libraryPtr->fileName[0]	= 0;
	libraryPtr->prefix	= (char *)ckalloc(strlen(prefix) + 1);
	strcpy(libraryPtr->prefix, prefix);
	libraryPtr->loadHandle	= NULL;
	libraryPtr->initProc	= initProc;
	libraryPtr->safeInitProc	= safeInitProc;
	libraryPtr->unloadProc = NULL;
	libraryPtr->safeUnloadProc = NULL;
	Tcl_MutexLock(&libraryMutex);
	libraryPtr->nextPtr		= firstLibraryPtr;
	firstLibraryPtr		= libraryPtr;
	Tcl_MutexUnlock(&libraryMutex);
    }

    if (interp != NULL) {

 *	Storage for all of the InterpLibrary functions for interp get deleted.
 *
 *----------------------------------------------------------------------
 */

static void
LoadCleanupProc(
    TCL_UNUSED(ClientData),	/* Pointer to first InterpLibrary structure
				 * for interp. */
    Tcl_Interp *interp)
{
    InterpLibrary *ipPtr;
    LoadedLibrary *libraryPtr;

    while (1) {
	ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
	if (ipPtr == NULL) {
	    break;
	}
	libraryPtr = ipPtr->libraryPtr;


	UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeLoad --

	/*
	 * 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 has been unloaded.
	 */

	if (!IsStatic(libraryPtr)) {
	    Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle);
	}
#endif

	ckfree(libraryPtr->fileName);
	ckfree(libraryPtr->prefix);
	ckfree(libraryPtr);

static Tcl_ObjCmdProc	TestlistobjCmd;
static Tcl_ObjCmdProc	TestobjCmd;
static Tcl_ObjCmdProc	TeststringobjCmd;

#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20

static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *))
{
    int i;
    Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
	if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
    }
    ckfree(varPtr);

    return TCL_ERROR;
}
#endif

static void
ZipfsExitHandler(
    TCL_UNUSED(ClientData)
)
{
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    if (ZipFS.initialized != -1) {
	hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
	if (hPtr == NULL) {
	    ZipfsFinalize();

    # Do all [load]ing of shared libraries in another process, so we can
    # delete the file and not get stuck because we're holding a reference to
    # it.
    set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
    exec [interpreter] << $cmd
    pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"

test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
    # Do all [load]ing of shared libraries in another process, so we can
    # delete the file and not get stuck because we're holding a reference to
    # it.
    #
    # This test depends on context from prior test, so repeat it.
	
    set script \
	"[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]"
    append script \n \
	"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
    exec [interpreter] << $script
    pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}"

if {[testConstraint $dll]} {
    file delete -force [file join $fullPkgPath [file tail $x]]
    removeFile [file join pkg pkga.tcl]
}

# Tolerate "namespace import" at the global scope

 * Prototypes for procedures defined later in this file:
 */

static int    PkguaEqObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int    PkguaQuoteObjCmd(ClientData clientData,
		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static void    CommandDeleted(ClientData clientData);

/*
 * In the following hash table we are going to store a struct that holds all
 * the command tokens created by Tcl_CreateObjCommand in an interpreter,
 * indexed by the interpreter. In this way, we can find which command tokens
 * we have registered in a specific interpreter, in order to unload them. We
 * need to keep the various command tokens we have registered, as they are the
 * only safe way to unregister our registered commands, even if they have been
 * renamed.
 *
 * Note that this code is utterly single-threaded.
 */

static Tcl_HashTable interpTokenMap;
static int interpTokenMapInitialised = 0;
#define MAX_REGISTERED_COMMANDS 2


static void
CommandDeleted(ClientData clientData)
{
    Tcl_Command *cmdToken = clientData;
    *cmdToken = NULL;
}

static void
PkguaInitTokensHashTable(void)
{
    if (interpTokenMapInitialised) {
	return;
    }

    if (code != TCL_OK) {
	return code;
    }

    Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);

    cmdTokens = PkguaInterpToTokens(interp);
    cmdTokens[cmdIndex] =
	    Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[cmdIndex],
		    CommandDeleted);
    cmdIndex++;
    cmdTokens[cmdIndex] =
	    Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,

		    &cmdTokens[cmdIndex], CommandDeleted);
    cmdIndex++;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Pkgua_SafeInit --