tclpkg.c

tcl是工具命令语言

		Tcl_DStringAppend(&command, " -exact", 7);
	    }
	    code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
	    Tcl_DStringFree(&command);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddErrorInfo(interp,
			    "\n    (\"package unknown\" script)");
		}
		return NULL;
	    }
	    Tcl_ResetResult(interp);
	}
    }

    if (pkgPtr->version == NULL) {
	Tcl_AppendResult(interp, "can't find package ", name,
		(char *) NULL);
	if (version != NULL) {
	    Tcl_AppendResult(interp, " ", version, (char *) NULL);
	}
	return NULL;
    }

    /*
     * At this point we know that the package is present.  Make sure that the
     * provided version meets the current requirement.
     */

    if (version == NULL) {
        if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
    if ((satisfies && !exact) || (result == 0)) {
	if (clientDataPtr) {
	    *clientDataPtr = pkgPtr->clientData;
	}
	return pkgPtr->version;
    }
    Tcl_AppendResult(interp, "version conflict for package \"",
	    name, "\": have ", pkgPtr->version, ", need ", version,
	    (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
 *
 *	Checks to see whether the specified package is present. If it
 *	is not then no additional action is taken.
 *
 * 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), NULL is returned and an error
 *	message is left in interp->result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgPresent(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_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgPresentEx(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. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Package *pkgPtr;
    int satisfies, result;

    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
    if (hPtr) {
	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	if (pkgPtr->version != NULL) {
	    
	    /*
	     * At this point we know that the package is present.  Make sure
	     * that the provided version meets the current requirement.
	     */

	    if (version == NULL) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}
		
		return pkgPtr->version;
	    }
	    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
	    if ((satisfies && !exact) || (result == 0)) {
		if (clientDataPtr) {
		    *clientDataPtr = pkgPtr->clientData;
		}
    
		return pkgPtr->version;
	    }
	    Tcl_AppendResult(interp, "version conflict for package \"",
			     name, "\": have ", pkgPtr->version,
			     ", need ", version, (char *) NULL);
	    return NULL;
	}
    }

    if (version != NULL) {
	Tcl_AppendResult(interp, "package ", name, " ", version,
			 " is not present", (char *) NULL);
    } else {
	Tcl_AppendResult(interp, "package ", name, " is not present",
			 (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PackageObjCmd --
 *
 *	This procedure is invoked to process the "package" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    static CONST char *pkgOptions[] = {
	"forget", "ifneeded", "names", "present", "provide", "require",
	"unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
    };
    enum pkgOptions {
	PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
	PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    CONST char *version;
    char *argv2, *argv3, *argv4;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
	case PKG_FORGET: {
	    char *keyString;
	    for (i = 2; i < objc; i++) {
		keyString = Tcl_GetString(objv[i]);
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
		if (hPtr == NULL) {
		    continue;	
		}
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		Tcl_DeleteHashEntry(hPtr);
		if (pkgPtr->version != NULL) {
		    ckfree(pkgPtr->version);
		}
		while (pkgPtr->availPtr != NULL) {
		    availPtr = pkgPtr->availPtr;
		    pkgPtr->availPtr = availPtr->nextPtr;
		    ckfree(availPtr->version);
		    Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		    ckfree((char *) availPtr);
		}
		ckfree((char *) pkgPtr);
	    }
	    break;
	}
	case PKG_IFNEEDED: {
	    int length;
	    if ((objc != 4) && (objc != 5)) {
		Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    if (CheckVersion(interp, argv3) != TCL_OK) {
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if (objc == 4) {
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
		if (hPtr == NULL) {
		    return TCL_OK;
		}
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
	    } else {
		pkgPtr = FindPackage(interp, argv2);
	    }
	    argv3 = Tcl_GetStringFromObj(objv[3], &length);
	    for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
		 prevPtr = availPtr, availPtr = availPtr->nextPtr) {
		if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
			== 0) {
		    if (objc == 4) {
			Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
			return TCL_OK;
		    }
		    Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
		    break;
		}
	    }
	    if (objc == 4) {
		return TCL_OK;
	    }
	    if (availPtr == NULL) {
		availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
		availPtr->version = ckalloc((unsigned) (length + 1));
		strcpy(availPtr->version, argv3);
		if (prevPtr == NULL) {
		    availPtr->nextPtr = pkgPtr->availPtr;
		    pkgPtr->availPtr = availPtr;
		} else {
		    availPtr->nextPtr = prevPtr->nextPtr;
		    prevPtr->nextPtr = availPtr;
		}
	    }
	    argv4 = Tcl_GetStringFromObj(objv[4], &length);
	    availPtr->script = ckalloc((unsigned) (length + 1));
	    strcpy(availPtr->script, argv4);
	    break;
	}
	case PKG_NAMES: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
	    tablePtr = &iPtr->packageTable;
	    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
		 hPtr = Tcl_NextHashEntry(&search)) {
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		    Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
		}
	    }
	    break;
	}
	case PKG_PRESENT: {
	    if (objc < 3) {
		presentSyntax:
		Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
		exact = 1;
	    } else {
		exact = 0;
	    }
	    version = NULL;
	    if (objc == (4 + exact)) {
		version =  Tcl_GetString(objv[3 + exact]);
		if (CheckVersion(interp, version) != TCL_OK) {
		    return TCL_ERROR;
		}
	    } else if ((objc != 3) || exact) {
		goto presentSyntax;
	    }
	    if (exact) {
		argv3 =  Tcl_GetString(objv[3]);
		version = Tcl_PkgPresent(interp, argv3, version, exact);
	    } else {
		version = Tcl_PkgPresent(interp, argv2, version, exact);
	    }
	    if (version == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
	    break;
	}
	case PKG_PROVIDE: {
	    if ((objc != 3) && (objc != 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    if (objc == 3) {
		hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
		if (hPtr != NULL) {
		    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		    if (pkgPtr->version != NULL) {
			Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
		    }
		}
		return TCL_OK;
	    }