diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 476 |
1 files changed, 258 insertions, 218 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 97a99e8..5cb1818 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. * - * RCS: @(#) $Id: tclPkg.c,v 1.3 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.4 1999/04/16 00:46:51 stanton Exp $ */ #include "tclInt.h" @@ -43,7 +43,7 @@ typedef struct Package { * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions * of this package. */ - ClientData clientData; /* Client data. */ + ClientData clientData; /* Client data. */ } Package; /* @@ -70,7 +70,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, @@ -109,6 +109,9 @@ Tcl_PkgProvideEx(interp, name, version, 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 \"", @@ -136,7 +139,7 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * 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 @@ -310,15 +313,13 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { - if (clientDataPtr) { + if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - return pkgPtr->version; } Tcl_AppendResult(interp, "version conflict for package \"", @@ -446,7 +447,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* *---------------------------------------------------------------------- * - * Tcl_PackageCmd -- + * Tcl_PackageObjCmd -- * * This procedure is invoked to process the "package" Tcl command. * See the user documentation for details on what it does. @@ -462,254 +463,293 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* 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", "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; - 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; + + 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); } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + break; + } + case PKG_IFNEEDED: { + int length; + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - while (pkgPtr->availPtr != NULL) { - availPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr->nextPtr; - ckfree(availPtr->version); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; } - 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; - } - if (argc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr == NULL) { + 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; } - 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); - 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; } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; } + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; } - if (argc == 4) { - return TCL_OK; + 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; } - 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; + 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 { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; + exact = 0; } - } - 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)); + 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_SetResult(interp, version, TCL_VOLATILE); + break; } - } else if ((c == 'p') && (strncmp(argv[1], "present", length) == 0) - && (length >=3)) { - if (argc < 3) { - presentSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " present ?-exact? package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { - exact = 1; - } else { - exact = 0; + 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; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); } - version = NULL; - if (argc == (4+exact)) { - version = argv[3+exact]; - if (CheckVersion(interp, version) != TCL_OK) { + 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; } - } else if ((argc != 3) || exact) { - goto presentSyntax; + Tcl_SetResult(interp, version, TCL_VOLATILE); + break; } - version = Tcl_PkgPresent(interp, argv[2+exact], version, exact); - if (version == NULL) { - 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; } - Tcl_SetResult(interp, version, TCL_VOLATILE); - } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0) - && (length >=3)) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " provide package ?version?\"", (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; } - if (argc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + 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); - if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); } } - 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_VSATISFIES: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); 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; - } - 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); - } - } else if (argc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); - } - if (argv[2][0] == 0) { - iPtr->packageUnknown = NULL; - } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(iPtr->packageUnknown, argv[2]); - } - } 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 ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - return TCL_ERROR; - } - 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; - } - 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); + 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; } - } 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; - } - 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, ", - "present, provide, require, unknown, vcompare, ", - "versions, or vsatisfies", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } @@ -815,7 +855,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. @@ -832,11 +872,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; } } |