/* 

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

 * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>

 * 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: tclPkg.c,v 1.9.2.9 2007/03/19 17:06:26 dgp Exp $

 *

 * TIP #268.

 * Heavily rewritten to handle the extend version numbers, and extended

 * package requirements.

 */

#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:

 */

#ifndef TCL_TIP268

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

#else

static int		CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string,

					       char** internal, int* stable);

static int		CompareVersions(CONST char *v1i, CONST char *v2i,

					int *isMajorPtr);

static int		CheckRequirement(Tcl_Interp *interp, CONST char *string);

static int		CheckAllRequirements(Tcl_Interp* interp,

					     int reqc, Tcl_Obj *CONST reqv[]);

static int		RequirementSatisfied(CONST char *havei, CONST char *req);

static int		AllRequirementsSatisfied(CONST char *havei,

						 int reqc, Tcl_Obj *CONST reqv[]);

static void		AddRequirementsToResult(Tcl_Interp* interp,

						int reqc, Tcl_Obj *CONST reqv[]);

static void		AddRequirementsToDString(Tcl_DString* dstring,

						 int reqc, Tcl_Obj *CONST reqv[]);

static Package *	FindPackage(Tcl_Interp *interp, CONST char *name);

static Tcl_Obj*		ExactRequirement(CONST char* version);

static void		VersionCleanupProc(ClientData clientData,

			    Tcl_Interp *interp);

#endif

/*

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

 *

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

 *

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

 */

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

}

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

#ifdef TCL_TIP268

    char* pvi;

    char* vi;

    int res;

#endif

    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;

    }

#ifndef TCL_TIP268

    if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {

#else

    if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {

	return TCL_ERROR;

    } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {

	Tcl_Free (pvi);

	return TCL_ERROR;

    }

    res = CompareVersions(pvi, vi, NULL);

    Tcl_Free (pvi);

    Tcl_Free (vi);

    if (res == 0) {

#endif

	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 / Tcl_PkgRequireProc --

 *

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

 *

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

 */

#ifndef TCL_TIP268

/*

 * Empty definition for Stubs when TIP 268 is not activated.

 */

EXPORT_C int

Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)

     Tcl_Interp *interp;	/* Interpreter in which package is now

				 * available. */

     CONST char *name;		/* Name of desired package. */

     int reqc;                  /* Requirements constraining the desired version. */

     Tcl_Obj *CONST reqv[];     /* 0 means to use the latest version available. */

     ClientData *clientDataPtr;

{

    return TCL_ERROR;

}

#endif

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

}

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

{

#ifndef TCL_TIP268

    Package *pkgPtr;

    PkgAvail *availPtr, *bestPtr;

    char *script;

    int code, satisfies, result, pass;

    Tcl_DString command;

#else

    Tcl_Obj *ov;

    int      res;

#endif

    /*

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

    }

#ifdef TCL_TIP268

    /* Translate between old and new API, and defer to the new function. */

    if (version == NULL) {

	res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);

    } else {

	if (exact) {

	    ov = ExactRequirement (version);

	} else {

	    ov = Tcl_NewStringObj (version,-1);

	}

	Tcl_IncrRefCount (ov);

	res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);

	Tcl_DecrRefCount (ov);

    }

    if (res != TCL_OK) {

	return NULL;

    }

    /* This function returns the version string explictly, and leaves the

     * interpreter result empty. However "Tcl_PkgRequireProc" above returned

     * the version through the interpreter result. Simply resetting the result

     * now potentially deletes the string (obj), and the pointer to its string

     * rep we have, as our result, may be dangling due to this. Our solution

     * is to remember the object in interp associated data, with a proper

     * reference count, and then reset the result. Now pointers will not

     * dangle. It will be a leak however if nothing is done. So the next time

     * we come through here we delete the object remembered by this call, as

     * we can then be sure that there is no pointer to its string around

     * anymore. Beyond that we have a deletion function which cleans up the last

     * remembered object which was not cleaned up directly, here.

     */

    ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL);

    if (ov != NULL) {

	Tcl_DecrRefCount (ov);

    }

    ov = Tcl_GetObjResult (interp);

    Tcl_IncrRefCount (ov);

    Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc,

		     (ClientData) ov);

    Tcl_ResetResult (interp);

    return Tcl_GetString (ov);

}

EXPORT_C int

Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)

     Tcl_Interp *interp;	/* Interpreter in which package is now

				 * available. */

     CONST char *name;		/* Name of desired package. */

     int reqc;                  /* Requirements constraining the desired version. */

     Tcl_Obj *CONST reqv[];     /* 0 means to use the latest version available. */

     ClientData *clientDataPtr;

{

    Interp *iPtr = (Interp *) interp;

    Package *pkgPtr;

    PkgAvail *availPtr,     *bestPtr, *bestStablePtr;

    char     *availVersion, *bestVersion; /* Internal rep. of versions */

    int       availStable;

    char *script;

    int code, satisfies, pass;

    Tcl_DString command;

    char* pkgVersionI;

#endif

    /*

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

	}

	/* 

	 * Check whether we're already attempting to load some version

	 * of this package (circular dependency detection).

	 */

	if (pkgPtr->clientData != NULL) {

	    Tcl_AppendResult(interp, "circular package dependency: ",

			     "attempt to provide ", name, " ",

			     (char *)(pkgPtr->clientData), " requires ", name, NULL);

#ifndef TCL_TIP268

	    if (version != NULL) {

		Tcl_AppendResult(interp, " ", version, NULL);

	    }

	    return NULL;

#else

	    AddRequirementsToResult (interp, reqc, reqv);

	    return TCL_ERROR;

#endif

	}

	/*

	 * The package isn't yet present. Search the list of available

	 * versions and invoke the script for the best available version.

	 *

	 * For TIP 268 we are actually locating the best, and the best stable

	 * version.  One of them is then chosen based on the selection mode.

	 */

#ifndef TCL_TIP268    

	bestPtr = NULL;

	for (availPtr = pkgPtr->availPtr; availPtr != NULL;

		availPtr = availPtr->nextPtr) {

	    if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,

		    bestPtr->version, (int *) NULL) <= 0)) {

#else

	bestPtr        = NULL;

	bestStablePtr  = NULL;

	bestVersion    = NULL;

	for (availPtr = pkgPtr->availPtr;

	     availPtr != NULL;

	     availPtr = availPtr->nextPtr) {

	    if (CheckVersionAndConvert (interp, availPtr->version,

					&availVersion, &availStable) != TCL_OK) {

		/* The provided version number is has invalid syntax. This

		 * should not happen. This should have been caught by the

		 * 'package ifneeded' registering the package.

		 */

#endif

		continue;

	    }

#ifndef TCL_TIP268

	    if (version != NULL) {

		result = ComparePkgVersions(availPtr->version, version,

			&satisfies);

		if ((result != 0) && exact) {

#else

	    if (bestPtr != NULL) {

		int res = CompareVersions (availVersion, bestVersion, NULL);

		/* Note: Use internal reps! */

		if (res <= 0) {

		    /* The version of the package sought is not as good as the

		     * currently selected version. Ignore it. */

		    Tcl_Free (availVersion);

		    availVersion = NULL;

#endif

		    continue;

		}

#ifdef TCL_TIP268

	    }

	    /* We have found a version which is better than our max. */

	    if (reqc > 0) {

		/* Check satisfaction of requirements */

		satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv);

#endif

		if (!satisfies) {

#ifdef TCL_TIP268

		    Tcl_Free (availVersion);

		    availVersion = NULL;

#endif

		    continue;

		}

	    }

	    bestPtr = availPtr;

#ifdef TCL_TIP268

	    if (bestVersion != NULL) Tcl_Free (bestVersion);

	    bestVersion  = availVersion;

	    availVersion = NULL;

	    /* If this new best version is stable then it also has to be

	     * better than the max stable version found so far.

	     */

	    if (availStable) {

		bestStablePtr = availPtr;

	    }

	}

	if (bestVersion != NULL) {

	    Tcl_Free (bestVersion);

	}

	/* Now choose a version among the two best. For 'latest' we simply

	 * take (actually keep) the best. For 'stable' we take the best

	 * stable, if there is any, or the best if there is nothing stable.

	 */

	if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) {

	    bestPtr = bestStablePtr;

#endif

	}

	if (bestPtr != NULL) {

	    /*