/* 

 * 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-1997 Sun Microsystems, Inc.

 * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  

 *

 * See the file "license.terms" for information on usage and redistribution

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 *

 * RCS: @(#) $Id: tclLoad.c,v 1.9 2003/02/01 23:37:29 kennykb Exp $

 */

#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 TclGetLoadedPackages).  All such packages

 * are linked together into a single list for the process.  Packages

 * are never unloaded, until the application exits, when 

 * TclFinalizeLoad is called, and these structures are 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_LoadHandle loadHandle;	/* Token for the loaded file which should be

				 * passed to (*unLoadProcPtr)() when the file

				 * is no longer needed.  If fileName is NULL,

				 * then this field is irrelevant. */

    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. */

    Tcl_FSUnloadFileProc *unLoadProcPtr;

				/* Procedure to use to unload this package.

				 * If NULL, then we do not attempt to unload

				 * the package.  If fileName is NULL, then

				 * this field is irrelevant. */

    struct LoadedPackage *nextPtr;

				/* Next in list of all packages loaded into

				 * this application process.  NULL means

				 * end of list. */

} LoadedPackage;

/*

 * TCL_THREADS

 * There is a global list of packages that is anchored at firstPackagePtr.

 * Access to this list is governed by a mutex.

 */

static LoadedPackage *firstPackagePtr = NULL;

				/* First in list of all packages loaded into

				 * this process. */

TCL_DECLARE_MUTEX(packageMutex)

/*

 * 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));

/*

 *----------------------------------------------------------------------

 *

 * Tcl_LoadObjCmd --

 *

 *	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_LoadObjCmd(dummy, interp, objc, objv)

    ClientData dummy;		/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    Tcl_Interp *target;

    LoadedPackage *pkgPtr, *defaultPtr;

    Tcl_DString pkgName, tmp, initName, safeInitName;

    Tcl_PackageInitProc *initProc, *safeInitProc;

    InterpPackage *ipFirstPtr, *ipPtr;

    int code, namesMatch, filesMatch;

    char *p, *fullFileName, *packageName;

    Tcl_LoadHandle loadHandle;

    Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;

    Tcl_UniChar ch;

    int offset;

    if ((objc < 2) || (objc > 4)) {

        Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");

	return TCL_ERROR;

    }

    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {

	return TCL_ERROR;

    }

    fullFileName = Tcl_GetString(objv[1]);

    Tcl_DStringInit(&pkgName);

    Tcl_DStringInit(&initName);

    Tcl_DStringInit(&safeInitName);

    Tcl_DStringInit(&tmp);

    packageName = NULL;

    if (objc >= 3) {

	packageName = Tcl_GetString(objv[2]);

	if (packageName[0] == '\0') {

	    packageName = NULL;

	}

    }

    if ((fullFileName[0] == 0) && (packageName == NULL)) {

	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 (objc == 4) {

	char *slaveIntName;

	slaveIntName = Tcl_GetString(objv[3]);

	target = Tcl_GetSlave(interp, slaveIntName);

	if (target == 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.

     */

    Tcl_MutexLock(&packageMutex);

    defaultPtr = NULL;

    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {

	if (packageName == NULL) {

	    namesMatch = 0;

	} else {

	    Tcl_DStringSetLength(&pkgName, 0);

	    Tcl_DStringAppend(&pkgName, packageName, -1);

	    Tcl_DStringSetLength(&tmp, 0);

	    Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);

	    Tcl_UtfToLower(Tcl_DStringValue(&pkgName));

	    Tcl_UtfToLower(Tcl_DStringValue(&tmp));

	    if (strcmp(Tcl_DStringValue(&tmp),

		    Tcl_DStringValue(&pkgName)) == 0) {

		namesMatch = 1;

	    } else {

		namesMatch = 0;

	    }

	}

	Tcl_DStringSetLength(&pkgName, 0);

	filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);

	if (filesMatch && (namesMatch || (packageName == NULL))) {

	    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;

	    Tcl_MutexUnlock(&packageMutex);

	    goto done;

	}

    }

    Tcl_MutexUnlock(&packageMutex);

    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 \"", packageName,

		    "\" isn't loaded statically", (char *) NULL);

	    code = TCL_ERROR;

	    goto done;

	}

	/*

	 * Figure out the module name if it wasn't provided explicitly.

	 */

	if (packageName != NULL) {

	    Tcl_DStringAppend(&pkgName, packageName, -1);

	} else {

	    int retc;

	    /*

	     * Threading note - this call used to be protected by a mutex.

	     */

	    retc = TclGuessPackageName(fullFileName, &pkgName);

	    if (!retc) {

		Tcl_Obj *splitPtr;

		Tcl_Obj *pkgGuessPtr;

		int pElements;

		char *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.

		 */

		splitPtr = Tcl_FSSplitPath(objv[1], &pElements);

		Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);

		pkgGuess = Tcl_GetString(pkgGuessPtr);

		if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')

			&& (pkgGuess[2] == 'b')) {

		    pkgGuess += 3;

		}

		for (p = pkgGuess; *p != 0; p += offset) {

		    offset = Tcl_UtfToUniChar(p, &ch);

		    if ((ch > 0x100)

			    || !(isalpha(UCHAR(ch)) /* INTL: ISO only */

				    || (UCHAR(ch) == '_'))) {

			break;

		    }

		}

		if (p == pkgGuess) {

		    Tcl_DecrRefCount(splitPtr);

		    Tcl_AppendResult(interp,

			    "couldn't figure out package name for ",

			    fullFileName, (char *) NULL);

		    code = TCL_ERROR;

		    goto done;

		}

		Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));

		Tcl_DecrRefCount(splitPtr);

	    }

	}

	/*

	 * Fix the capitalization in the package name so that the first

	 * character is in caps (or title case) but the others are all

	 * lower-case.

	 */

	Tcl_DStringSetLength(&pkgName,

		Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));

	/*

	 * 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.

	 */

	Tcl_MutexLock(&packageMutex);

	code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),

		Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,

		&loadHandle,&unLoadProcPtr);

	Tcl_MutexUnlock(&packageMutex);

	if (code != TCL_OK) {

	    goto done;

	}

	if (initProc == NULL) {

	    Tcl_AppendResult(interp, "couldn't find procedure ",

		    Tcl_DStringValue(&initName), (char *) NULL);

	    if (unLoadProcPtr != NULL) {

		(*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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C 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);

    }

}