tclpkg.c

tcl是工具命令语言

	    argv3 = Tcl_GetString(objv[3]);
	    if (CheckVersion(interp, argv3) != TCL_OK) {
		return TCL_ERROR;
	    }
	    return Tcl_PkgProvide(interp, argv2, argv3);
	}
	case PKG_REQUIRE: {
	    if (objc < 3) {
		requireSyntax:
		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 requireSyntax;
	    }
	    if (exact) {
		argv3 =  Tcl_GetString(objv[3]);
		version = Tcl_PkgRequire(interp, argv3, version, exact);
	    } else {
		version = Tcl_PkgRequire(interp, argv2, version, exact);
	    }
	    if (version == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
	    break;
	}
	case PKG_UNKNOWN: {
	    int length;
	    if (objc == 2) {
		if (iPtr->packageUnknown != NULL) {
		    Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
		}
	    } else if (objc == 3) {
		if (iPtr->packageUnknown != NULL) {
		    ckfree(iPtr->packageUnknown);
		}
		argv2 = Tcl_GetStringFromObj(objv[2], &length);
		if (argv2[0] == 0) {
		    iPtr->packageUnknown = NULL;
		} else {
		    iPtr->packageUnknown = (char *) ckalloc((unsigned)
			    (length + 1));
		    strcpy(iPtr->packageUnknown, argv2);
		}
	    } else {
		Tcl_WrongNumArgs(interp, 2, objv, "?command?");
		return TCL_ERROR;
	    }
	    break;
	}
	case PKG_VCOMPARE: {
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    argv2 = Tcl_GetString(objv[2]);
	    if ((CheckVersion(interp, argv2) != TCL_OK)
		    || (CheckVersion(interp, argv3) != TCL_OK)) {
		return TCL_ERROR;
	    }
	    Tcl_SetIntObj(Tcl_GetObjResult(interp),
		    ComparePkgVersions(argv2, argv3, (int *) NULL));
	    break;
	}
	case PKG_VERSIONS: {
	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "package");
		return TCL_ERROR;
	    }
	    argv2 = Tcl_GetString(objv[2]);
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
		for (availPtr = pkgPtr->availPtr; availPtr != NULL;
		     availPtr = availPtr->nextPtr) {
		    Tcl_AppendElement(interp, availPtr->version);
		}
	    }
	    break;
	}
	case PKG_VSATISFIES: {
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
		return TCL_ERROR;
	    }
	    argv3 = Tcl_GetString(objv[3]);
	    argv2 = Tcl_GetString(objv[2]);
	    if ((CheckVersion(interp, argv2) != TCL_OK)
		    || (CheckVersion(interp, argv3) != TCL_OK)) {
		return TCL_ERROR;
	    }
	    ComparePkgVersions(argv2, argv3, &satisfies);
	    Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
	    break;
	}
	default: {
	    panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *	This procedure finds the Package record for a particular package
 *	in a particular interpreter, creating a record if one doesn't
 *	already exist.
 *
 * Results:
 *	The return value is a pointer to the Package record for the
 *	package.
 *
 * Side effects:
 *	A new Package record may be created.
 *
 *----------------------------------------------------------------------
 */

static Package *
FindPackage(interp, name)
    Tcl_Interp *interp;		/* Interpreter to use for package lookup. */
    CONST char *name;		/* Name of package to fine. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    int new;
    Package *pkgPtr;

    hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
    if (new) {
	pkgPtr = (Package *) ckalloc(sizeof(Package));
	pkgPtr->version = NULL;
	pkgPtr->availPtr = NULL;
	pkgPtr->clientData = NULL;
	Tcl_SetHashValue(hPtr, pkgPtr);
    } else {
	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
    }
    return pkgPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreePackageInfo --
 *
 *	This procedure is called during interpreter deletion to
 *	free all of the package-related information for the
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFreePackageInfo(iPtr)
    Interp *iPtr;		/* Interpereter that is being deleted. */
{
    Package *pkgPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
	pkgPtr = (Package *) Tcl_GetHashValue(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);
    }
    Tcl_DeleteHashTable(&iPtr->packageTable);
    if (iPtr->packageUnknown != NULL) {
	ckfree(iPtr->packageUnknown);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * CheckVersion --
 *
 *	This procedure checks to see whether a version number has
 *	valid syntax.
 *
 * Results:
 *	If string is a properly formed version number the TCL_OK
 *	is returned.  Otherwise TCL_ERROR is returned and an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CheckVersion(interp, string)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *string;		/* Supposedly a version number, which is
				 * groups of decimal digits separated
				 * by dots. */
{
    CONST char *p = string;
    char prevChar;
    
    if (!isdigit(UCHAR(*p))) {	/* INTL: digit */
	goto error;
    }
    for (prevChar = *p, p++; *p != 0; p++) {
	if (!isdigit(UCHAR(*p)) &&
		((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
	    goto error;
	}
	prevChar = *p;
    }
    if (prevChar != '.') {
	return TCL_OK;
    }

    error:
    Tcl_AppendResult(interp, "expected version number but got \"",
	    string, "\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ComparePkgVersions --
 *
 *	This procedure compares two version numbers.
 *
 * Results:
 *	The return value is -1 if v1 is less than v2, 0 if the two
 *	version numbers are the same, and 1 if v1 is greater than v2.
 *	If *satPtr is non-NULL, the word it points to is filled in
 *	with 1 if v2 >= v1 and both numbers have the same major number
 *	or 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ComparePkgVersions(v1, v2, satPtr)
    CONST char *v1;
    CONST char *v2;		/* Versions strings, of form 2.1.3 (any
				 * number of version numbers). */
    int *satPtr;		/* If non-null, the word pointed to is
				 * filled in with a 0/1 value.  1 means
				 * v1 "satisfies" v2:  v1 is greater than
				 * or equal to v2 and both version numbers
				 * have the same major number. */
{
    int thisIsMajor, n1, n2;

    /*
     * Each iteration of the following loop processes one number from
     * each string, terminated by a ".".  If those numbers don't match
     * then the comparison is over;  otherwise, we loop back for the
     * next number.
     */

    thisIsMajor = 1;
    while (1) {
	/*
	 * Parse one decimal number from the front of each string.
	 */

	n1 = n2 = 0;
	while ((*v1 != 0) && (*v1 != '.')) {
	    n1 = 10*n1 + (*v1 - '0');
	    v1++;
	}
	while ((*v2 != 0) && (*v2 != '.')) {
	    n2 = 10*n2 + (*v2 - '0');
	    v2++;
	}

	/*
	 * Compare and go on to the next version number if the
	 * current numbers match.
	 */

	if (n1 != n2) {
	    break;
	}
	if (*v1 != 0) {
	    v1++;
	} else if (*v2 == 0) {
	    break;
	}
	if (*v2 != 0) {
	    v2++;
	}
	thisIsMajor = 0;
    }
    if (satPtr != NULL) {
	*satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
    }
    if (n1 > n2) {
	return 1;
    } else if (n1 == n2) {
	return 0;
    } else {
	return -1;
    }
}