summaryrefslogtreecommitdiffstats
path: root/generic/tclPkg.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclPkg.c')
-rw-r--r--generic/tclPkg.c410
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;
}
}
generated by cgit v0.12 at 2024-07-15 21:19:57 (GMT)