tclload.c

linux系统下的音频通信

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