diff options
author | stanton <stanton> | 1998-09-21 23:39:52 (GMT) |
---|---|---|
committer | stanton <stanton> | 1998-09-21 23:39:52 (GMT) |
commit | 494c2de3a748b449c69ce322a1a741f5a31fd4d5 (patch) | |
tree | c3ece48c0ae3f4ba54787e0e8e729b65752ef3f9 /generic/tclPkg.c | |
parent | 7a698c0488d99c0af42022714638ae1ba2afaa49 (diff) | |
download | tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.zip tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.gz tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.bz2 |
Added contents of Tcl 8.1a2
Diffstat (limited to 'generic/tclPkg.c')
-rw-r--r-- | generic/tclPkg.c | 410 |
1 files changed, 222 insertions, 188 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 4a58eac..3b88299 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclPkg.c 1.9 97/05/14 13:23:51 + * SCCS: @(#) tclPkg.c 1.13 98/01/06 11:07:58 */ #include "tclInt.h" @@ -69,7 +69,7 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, * 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 interp->result. + * message is left in the interp's result. * * Side effects: * The interpreter remembers that this package is available, @@ -122,7 +122,7 @@ Tcl_PkgProvide(interp, name, version) * 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 interp->result. + * message is left in the interp's result. * * Side effects: * The script from some previous "package ifneeded" command may @@ -273,7 +273,7 @@ Tcl_PkgRequire(interp, name, version, exact) /* *---------------------------------------------------------------------- * - * Tcl_PackageCmd -- + * Tcl_PackageObjCmd -- * * This procedure is invoked to process the "package" Tcl command. * See the user documentation for details on what it does. @@ -289,226 +289,260 @@ Tcl_PkgRequire(interp, name, version, exact) /* ARGSUSED */ int -Tcl_PackageCmd(dummy, interp, argc, argv) +Tcl_PackageObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *pkgOptions[] = { + "forget", "ifneeded", "names", "provide", "require", "unknown", + "vcompare", "versions", "vsatisfies", (char *) NULL + }; + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PROVIDE, + PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, + PKG_VSATISFIES + }; Interp *iPtr = (Interp *) interp; - size_t length; - int c, exact, i, satisfies; + int optionIndex, exact, i, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - char *version; - char buf[30]; + char *version, *argv2, *argv3, *argv4; - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { - for (i = 2; i < argc; i++) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); - if (hPtr == NULL) { - return TCL_OK; - } - 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); + + 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) { + return TCL_OK; + } + 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); } - ckfree((char *) pkgPtr); - } - } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { - if ((argc != 4) && (argc != 5)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ifneeded package version ?script?\"", (char *) NULL); - return TCL_ERROR; - } - if (CheckVersion(interp, argv[3]) != TCL_OK) { - return TCL_ERROR; + break; } - if (argc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr == NULL) { - return TCL_OK; + case PKG_IFNEEDED: { + int length; + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - } else { - pkgPtr = FindPackage(interp, argv[2]); - } - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; - prevPtr = availPtr, availPtr = availPtr->nextPtr) { - if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) - == 0) { - if (argc == 4) { - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + 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; } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; - } - } - if (argc == 4) { - return TCL_OK; - } - if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); - strcpy(availPtr->version, argv[3]); - if (prevPtr == NULL) { - availPtr->nextPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr; + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; + pkgPtr = FindPackage(interp, argv2); } - } - availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); - strcpy(availPtr->script, argv[4]); - } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " names\"", (char *) 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)); + 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; } - } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " provide package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr != NULL) { + 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) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } } - return TCL_OK; - } - if (CheckVersion(interp, argv[3]) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_PkgProvide(interp, argv[2], argv[3]); - } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { - if (argc < 3) { - requireSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " require ?-exact? package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { - exact = 1; - } else { - exact = 0; + break; } - version = NULL; - if (argc == (4+exact)) { - version = argv[3+exact]; - if (CheckVersion(interp, version) != TCL_OK) { + case PKG_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); return TCL_ERROR; } - } else if ((argc != 3) || exact) { - goto requireSyntax; - } - version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); - if (version == NULL) { - 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; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); } - Tcl_SetResult(interp, version, TCL_VOLATILE); - } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { - if (argc == 2) { - if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + case PKG_REQUIRE: { + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; } - } else if (argc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); + 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 (argv[2][0] == 0) { - iPtr->packageUnknown = NULL; + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(iPtr->packageUnknown, argv[2]); + version = Tcl_PkgRequire(interp, argv2, version, exact); } - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " unknown ?command?\"", (char *) NULL); - return TCL_ERROR; - } - } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " vcompare version1 version2\"", (char *) NULL); - return TCL_ERROR; + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, version, TCL_VOLATILE); + break; } - if ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - return TCL_ERROR; + 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; } - TclFormatInt(buf, ComparePkgVersions(argv[2], argv[3], (int *) NULL)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " versions package\"", (char *) NULL); - return TCL_ERROR; + 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; } - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + 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; } - } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " vsatisfies version1 version2\"", (char *) NULL); - return TCL_ERROR; + 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; } - if ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - return TCL_ERROR; + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } - ComparePkgVersions(argv[2], argv[3], &satisfies); - TclFormatInt(buf, satisfies); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be forget, ifneeded, names, ", - "provide, require, unknown, vcompare, ", - "versions, or vsatisfies", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } @@ -613,7 +647,7 @@ TclFreePackageInfo(iPtr) * 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 interp->result. + * message is left in the interp's result. * * Side effects: * None. @@ -630,11 +664,11 @@ CheckVersion(interp, string) { char *p = string; - if (!isdigit(UCHAR(*p))) { + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } for (p++; *p != 0; p++) { - if (!isdigit(UCHAR(*p)) && (*p != '.')) { + if (!isdigit(UCHAR(*p)) && (*p != '.')) { /* INTL: digit */ goto error; } } |