tclpkg.c

tcl是工具命令语言

/* 
 * tclPkg.c --
 *
 *	This file implements package and version control for Tcl via
 *	the "package" command and a few C APIs.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkg.c,v 1.9 2002/02/22 22:36:09 dgp Exp $
 */

#include "tclInt.h"

/*
 * Each invocation of the "package ifneeded" command creates a structure
 * of the following type, which is used to load the package into the
 * interpreter if it is requested with a "package require" command.
 */

typedef struct PkgAvail {
    char *version;		/* Version string; malloc'ed. */
    char *script;		/* Script to invoke to provide this version
				 * of the package.  Malloc'ed and protected
				 * by Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr;	/* Next in list of available versions of
				 * the same package. */
} PkgAvail;

/*
 * For each package that is known in any way to an interpreter, there
 * is one record of the following type.  These records are stored in
 * the "packageTable" hash table in the interpreter, keyed by
 * package name such as "Tk" (no version number).
 */

typedef struct Package {
    char *version;		/* Version that has been supplied in this
				 * interpreter via "package provide"
				 * (malloc'ed).  NULL means the package doesn't
				 * exist in this interpreter yet. */
    PkgAvail *availPtr;		/* First in list of all available versions
				 * of this package. */
    ClientData clientData;	/* Client data. */
} Package;

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

static int		CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *string));
static int		ComparePkgVersions _ANSI_ARGS_((CONST char *v1, 
                            CONST char *v2,
			    int *satPtr));
static Package *	FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *name));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
 *
 *	This procedure is invoked to declare that a particular version
 *	of a particular package is now present in an interpreter.  There
 *	must not be any other version of this package already
 *	provided in the interpreter.
 *
 * Results:
 *	Normally returns TCL_OK;  if there is already another version
 *	of the package loaded then TCL_ERROR is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The interpreter remembers that this package is available,
 *	so that no other version of the package may be provided for
 *	the interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PkgProvide(interp, name, version)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
{
    return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}

int
Tcl_PkgProvideEx(interp, name, version, clientData)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of package. */
    CONST char *version;	/* Version string for package. */
    ClientData clientData;      /* clientdata for this package (normally
                                 * used for C callback function table) */
{
    Package *pkgPtr;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
	strcpy(pkgPtr->version, version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }
    if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "conflicting versions provided for package \"",
	    name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgRequire / Tcl_PkgRequireEx --
 *
 *	This procedure is called by code that depends on a particular
 *	version of a particular package.  If the package is not already
 *	provided in the interpreter, this procedure invokes a Tcl script
 *	to provide it.  If the package is already provided, this
 *	procedure makes sure that the caller's needs don't conflict with
 *	the version that is present.
 *
 * Results:
 *	If successful, returns the version string for the currently
 *	provided version of the package, which may be different from
 *	the "version" argument.  If the caller's requirements
 *	cannot be met (e.g. the version requested conflicts with
 *	a currently provided version, or the required version cannot
 *	be found, or the script to provide the required version
 *	generates an error), NULL is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	The script from some previous "package ifneeded" command may
 *	be invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgRequire(interp, name, version, exact)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
{
    return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter in which package is now
				 * available. */
    CONST char *name;		/* Name of desired package. */
    CONST char *version;	/* Version string for desired version;
				 * NULL means use the latest version
				 * available. */
    int exact;			/* Non-zero means that only the particular
				 * version given is acceptable. Zero means
				 * use the latest compatible version. */
    ClientData *clientDataPtr;	/* Used to return the client data for this
				 * package. If it is NULL then the client
				 * data is not returned. This is unchanged
				 * if this call fails for any reason. */
{
    Package *pkgPtr;
    PkgAvail *availPtr, *bestPtr;
    char *script;
    int code, satisfies, result, pass;
    Tcl_DString command;

    /*
     * If an attempt is being made to load this into a standalone executable
     * on a platform where backlinking is not supported then this must be
     * a shared version of Tcl (Otherwise the load would have failed).
     * Detect this situation by checking that this library has been correctly
     * initialised. If it has not been then return immediately as nothing will
     * work.
     */
    
    if (tclEmptyStringRep == NULL) {

	/*
	 * OK, so what's going on here?
	 *
	 * First, what are we doing?  We are performing a check on behalf of
	 * one particular caller, Tcl_InitStubs().  When a package is
	 * stub-enabled, it is statically linked to libtclstub.a, which
	 * contains a copy of Tcl_InitStubs().  When a stub-enabled package
	 * is loaded, its *_Init() function is supposed to call
	 * Tcl_InitStubs() before calling any other functions in the Tcl
	 * library.  The first Tcl function called by Tcl_InitStubs() through
	 * the stub table is Tcl_PkgRequireEx(), so this code right here is
	 * the first code that is part of the original Tcl library in the
	 * executable that gets executed on behalf of a newly loaded
	 * stub-enabled package.
	 *
	 * One easy error for the developer/builder of a stub-enabled package
	 * to make is to forget to define USE_TCL_STUBS when compiling the
	 * package.  When that happens, the package will contain symbols
	 * that are references to the Tcl library, rather than function
	 * pointers referencing the stub table.  On platforms that lack
	 * backlinking, those unresolved references may cause the loading
	 * of the package to also load a second copy of the Tcl library,
	 * leading to all kinds of trouble.  We would like to catch that
	 * error and report a useful message back to the user.  That's
	 * what we're doing.
	 *
	 * Second, how does this work?  If we reach this point, then the
	 * global variable tclEmptyStringRep has the value NULL.  Compare
	 * that with the definition of tclEmptyStringRep near the top of
	 * the file generic/tclObj.c.  It clearly should not have the value
	 * NULL; it should point to the char tclEmptyString.  If we see it
	 * having the value NULL, then somehow we are seeing a Tcl library
	 * that isn't completely initialized, and that's an indicator for the
	 * error condition described above.  (Further explanation is welcome.)
	 *
	 * Third, so what do we do about it?  This situation indicates
	 * the package we just loaded wasn't properly compiled to be
	 * stub-enabled, yet it thinks it is stub-enabled (it called
	 * Tcl_InitStubs()).  We want to report that the package just
	 * loaded is broken, so we want to place an error message in
	 * the interpreter result and return NULL to indicate failure
	 * to Tcl_InitStubs() so that it will also fail.  (Further
	 * explanation why we don't want to Tcl_Panic() is welcome.
	 * After all, two Tcl libraries can't be a good thing!)
	 *
	 * Trouble is that's going to be tricky.  We're now using a Tcl
	 * library that's not fully initialized.  In particular, it 
	 * doesn't have a proper value for tclEmptyStringRep.  The
	 * Tcl_Obj system heavily depends on the value of tclEmptyStringRep
	 * and all of Tcl depends (increasingly) on the Tcl_Obj system, we
	 * need to correct that flaw before making the calls to set the 
	 * interpreter result to the error message.  That's the only flaw
	 * corrected; other problems with initialization of the Tcl library
	 * are not remedied, so be very careful about adding any other calls
	 * here without checking how they behave when initialization is
	 * incomplete.
	 */

	tclEmptyStringRep = &tclEmptyString;
        Tcl_AppendResult(interp, "Cannot load package \"", name, 
                "\" in standalone executable: This package is not ",
                "compiled with stub support", NULL);
        return NULL;
    }

    /*
     * It can take up to three passes to find the package:  one pass to
     * run the "package unknown" script, one to run the "package ifneeded"
     * script for a specific version, and a final pass to lookup the
     * package loaded by the "package ifneeded" script.
     */

    for (pass = 1; ; pass++) {
	pkgPtr = FindPackage(interp, name);
	if (pkgPtr->version != NULL) {
	    break;
	}

	/*
	 * The package isn't yet present.  Search the list of available
	 * versions and invoke the script for the best available version.
	 */
    
	bestPtr = NULL;
	for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		availPtr = availPtr->nextPtr) {
	    if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
		    bestPtr->version, (int *) NULL) <= 0)) {
		continue;
	    }
	    if (version != NULL) {
		result = ComparePkgVersions(availPtr->version, version,
			&satisfies);
		if ((result != 0) && exact) {
		    continue;
		}
		if (!satisfies) {
		    continue;
		}
	    }
	    bestPtr = availPtr;
	}
	if (bestPtr != NULL) {
	    /*
	     * We found an ifneeded script for the package.  Be careful while
	     * executing it:  this could cause reentrancy, so (a) protect the
	     * script itself from deletion and (b) don't assume that bestPtr
	     * will still exist when the script completes.
	     */
	
	    script = bestPtr->script;
	    Tcl_Preserve((ClientData) script);
	    code = Tcl_GlobalEval(interp, script);
	    Tcl_Release((ClientData) script);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddErrorInfo(interp,
			    "\n    (\"package ifneeded\" script)");
		}
		return NULL;
	    }
	    Tcl_ResetResult(interp);
	    pkgPtr = FindPackage(interp, name);
	    break;
	}

	/*
	 * Package not in the database.  If there is a "package unknown"
	 * command, invoke it (but only on the first pass;  after that,
	 * we should not get here in the first place).
	 */

	if (pass > 1) {
	    break;
	}
	script = ((Interp *) interp)->packageUnknown;
	if (script != NULL) {
	    Tcl_DStringInit(&command);
	    Tcl_DStringAppend(&command, script, -1);
	    Tcl_DStringAppendElement(&command, name);
	    Tcl_DStringAppend(&command, " ", 1);
	    Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
		    -1);
	    if (exact) {