summaryrefslogtreecommitdiffstats
path: root/generic/tclPkg.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclPkg.c')
-rw-r--r--generic/tclPkg.c424
1 files changed, 235 insertions, 189 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index b9874f5..df90cea 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -10,8 +10,6 @@
* 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.30 2007/09/17 14:50:44 dgp Exp $
- *
* TIP #268.
* Heavily rewritten to handle the extend version numbers, and extended
* package requirements.
@@ -44,11 +42,11 @@ typedef struct PkgAvail {
typedef struct Package {
char *version; /* Version that has been supplied in this
* interpreter via "package provide"
- * (malloc'ed). NULL means the package
- * doesn't exist in this interpreter yet. */
+ * (malloc'ed). NULL means the package doesn't
+ * exist in this interpreter yet. */
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
- ClientData clientData; /* Client data. */
+ const void *clientData; /* Client data. */
} Package;
/*
@@ -56,24 +54,24 @@ typedef struct Package {
*/
static int CheckVersionAndConvert(Tcl_Interp *interp,
- CONST char *string, char **internal, int *stable);
+ const char *string, char **internal, int *stable);
static int CompareVersions(char *v1i, char *v2i,
int *isMajorPtr);
static int CheckRequirement(Tcl_Interp *interp,
- CONST char *string);
+ const char *string);
static int CheckAllRequirements(Tcl_Interp *interp, int reqc,
- Tcl_Obj *CONST reqv[]);
-static int RequirementSatisfied(char *havei, CONST char *req);
+ Tcl_Obj *const reqv[]);
+static int RequirementSatisfied(char *havei, const char *req);
static int SomeRequirementSatisfied(char *havei, int reqc,
- Tcl_Obj *CONST reqv[]);
+ Tcl_Obj *const reqv[]);
static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
- Tcl_Obj *CONST reqv[]);
+ Tcl_Obj *const reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
- int reqc, Tcl_Obj *CONST reqv[]);
-static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
-static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
- int reqc, Tcl_Obj *CONST reqv[],
- ClientData *clientDataPtr);
+ int reqc, Tcl_Obj *const reqv[]);
+static Package * FindPackage(Tcl_Interp *interp, const char *name);
+static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
+ int reqc, Tcl_Obj *const reqv[],
+ void *clientDataPtr);
/*
* Helper macros.
@@ -108,12 +106,13 @@ static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
*----------------------------------------------------------------------
*/
+#undef Tcl_PkgProvide
int
Tcl_PkgProvide(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
- CONST char *name, /* Name of package. */
- CONST char *version) /* Version string for package. */
+ const char *name, /* Name of package. */
+ const char *version) /* Version string for package. */
{
return Tcl_PkgProvideEx(interp, name, version, NULL);
}
@@ -122,9 +121,9 @@ int
Tcl_PkgProvideEx(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
- CONST char *name, /* Name of package. */
- CONST char *version, /* Version string for package. */
- ClientData clientData) /* clientdata for this package (normally used
+ const char *name, /* Name of package. */
+ const char *version, /* Version string for package. */
+ const void *clientData) /* clientdata for this package (normally used
* for C callback function table) */
{
Package *pkgPtr;
@@ -156,8 +155,10 @@ Tcl_PkgProvideEx(
}
return TCL_OK;
}
- Tcl_AppendResult(interp, "conflicting versions provided for package \"",
- name, "\": ", pkgPtr->version, ", then ", version, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "conflicting versions provided for package \"%s\": %s, then %s",
+ name, pkgPtr->version, version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
@@ -188,12 +189,13 @@ Tcl_PkgProvideEx(
*----------------------------------------------------------------------
*/
-CONST char *
+#undef Tcl_PkgRequire
+const char *
Tcl_PkgRequire(
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
+ 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
@@ -202,17 +204,17 @@ Tcl_PkgRequire(
return Tcl_PkgRequireEx(interp, name, version, exact, NULL);
}
-CONST char *
+const char *
Tcl_PkgRequireEx(
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
+ 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
+ void *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. */
@@ -285,18 +287,21 @@ Tcl_PkgRequireEx(
*/
tclEmptyStringRep = &tclEmptyString;
- Tcl_AppendResult(interp, "Cannot load package \"", name,
- "\" in standalone executable: This package is not "
- "compiled with stub support", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Cannot load package \"%s\" in standalone executable:"
+ " This package is not compiled with stub support", name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
return NULL;
}
- /* Translate between old and new API, and defer to the new function. */
+ /*
+ * Translate between old and new API, and defer to the new function.
+ */
if (version == NULL) {
result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
} else {
- if (exact && TCL_OK
+ if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
}
@@ -316,12 +321,12 @@ int
Tcl_PkgRequireProc(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
- CONST char *name, /* Name of desired package. */
+ const char *name, /* Name of desired package. */
int reqc, /* Requirements constraining the desired
* version. */
- Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
+ Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ void *clientDataPtr)
{
const char *result =
PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
@@ -337,23 +342,25 @@ static const char *
PkgRequireCore(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
- CONST char *name, /* Name of desired package. */
+ const char *name, /* Name of desired package. */
int reqc, /* Requirements constraining the desired
* version. */
- Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
+ Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ void *clientDataPtr)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion;
/* Internal rep. of versions */
- int availStable;
- char *script;
- int code, satisfies, pass;
+ int availStable, code, satisfies, pass;
+ char *script, *pkgVersionI;
Tcl_DString command;
- char *pkgVersionI;
+
+ if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) {
+ return NULL;
+ }
/*
* It can take up to three passes to find the package: one pass to run the
@@ -368,16 +375,18 @@ PkgRequireCore(
break;
}
- /*
- * Check whether we're already attempting to load some version
- * of this package (circular dependency detection).
+ /*
+ * Check whether we're already attempting to load some version of this
+ * package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
- Tcl_AppendResult(interp, "circular package dependency: "
- "attempt to provide ", name, " ",
- (char *) pkgPtr->clientData, " requires ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "circular package dependency:"
+ " attempt to provide %s %s requires %s",
+ name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return NULL;
}
@@ -397,7 +406,7 @@ PkgRequireCore(
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/*
- * The provided version number is has invalid syntax. This
+ * The provided version number has invalid syntax. This
* should not happen. This should have been caught by the
* 'package ifneeded' registering the package.
*/
@@ -408,7 +417,10 @@ PkgRequireCore(
if (bestPtr != NULL) {
int res = CompareVersions(availVersion, bestVersion, NULL);
- /* Note: Use internal reps! */
+ /*
+ * Note: Use internal reps!
+ */
+
if (res <= 0) {
/*
* The version of the package sought is not as good as the
@@ -426,11 +438,9 @@ PkgRequireCore(
*/
if (reqc > 0) {
- /*
- * Check satisfaction of requirements.
- */
+ /* Check satisfaction of requirements. */
- satisfies = SomeRequirementSatisfied(availVersion,reqc,reqv);
+ satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
@@ -478,27 +488,28 @@ PkgRequireCore(
* will still exist when the script completes.
*/
- CONST char *versionToProvide = bestPtr->version;
+ char *versionToProvide = bestPtr->version;
script = bestPtr->script;
- pkgPtr->clientData = (ClientData) versionToProvide;
- Tcl_Preserve((ClientData) script);
- Tcl_Preserve((ClientData) versionToProvide);
+ pkgPtr->clientData = versionToProvide;
+ Tcl_Preserve(script);
+ Tcl_Preserve(versionToProvide);
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
- Tcl_Release((ClientData) script);
+ Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
code = TCL_ERROR;
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide,
- " failed: no version of package ", name,
- " provided", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " no version of package %s provided",
+ name, versionToProvide, name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
+ NULL);
} else {
char *pvi, *vi;
- int res;
if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
NULL) != TCL_OK) {
@@ -508,26 +519,30 @@ PkgRequireCore(
ckfree(pvi);
code = TCL_ERROR;
} else {
- res = CompareVersions(pvi, vi, NULL);
+ int res = CompareVersions(pvi, vi, NULL);
+
ckfree(pvi);
ckfree(vi);
-
if (res != 0) {
code = TCL_ERROR;
- Tcl_AppendResult(interp,
- "attempt to provide package ", name, " ",
- versionToProvide, " failed: package ",
- name, " ", pkgPtr->version,
- " provided instead", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " package %s %s provided instead",
+ name, versionToProvide,
+ name, pkgPtr->version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+ "WRONGPROVIDE", NULL);
}
}
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide, " failed: "
- "bad return code: ", TclGetString(codePtr), NULL);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " bad return code: %s",
+ name, versionToProvide, TclGetString(codePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
code = TCL_ERROR;
}
@@ -537,7 +552,7 @@ PkgRequireCore(
"\n (\"package ifneeded %s %s\" script)",
name, versionToProvide));
}
- Tcl_Release((ClientData) versionToProvide);
+ Tcl_Release(versionToProvide);
if (code != TCL_OK) {
/*
@@ -584,11 +599,9 @@ PkgRequireCore(
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
- Tcl_Obj *codePtr = Tcl_NewIntObj(code);
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad return code: ",
- TclGetString(codePtr), NULL);
- Tcl_DecrRefCount(codePtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad return code: %d", code));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
@@ -601,7 +614,9 @@ PkgRequireCore(
}
if (pkgPtr->version == NULL) {
- Tcl_AppendResult(interp, "can't find package ", name, NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't find package %s", name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
}
@@ -611,26 +626,29 @@ PkgRequireCore(
* provided version meets the current requirements.
*/
- if (reqc == 0) {
- satisfies = 1;
- } else {
+ if (reqc != 0) {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
- }
- if (satisfies) {
- if (clientDataPtr) {
- *clientDataPtr = pkgPtr->clientData;
+ if (!satisfies) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "version conflict for package \"%s\": have %s, need",
+ name, pkgPtr->version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+ NULL);
+ AddRequirementsToResult(interp, reqc, reqv);
+ return NULL;
}
- return pkgPtr->version;
}
- Tcl_AppendResult(interp, "version conflict for package \"", name,
- "\": have ", pkgPtr->version, ", need", NULL);
- AddRequirementsToResult(interp, reqc, reqv);
- return NULL;
+ if (clientDataPtr) {
+ const void **ptr = (const void **) clientDataPtr;
+
+ *ptr = pkgPtr->clientData;
+ }
+ return pkgPtr->version;
}
/*
@@ -654,12 +672,13 @@ PkgRequireCore(
*----------------------------------------------------------------------
*/
-CONST char *
+#undef Tcl_PkgPresent
+const char *
Tcl_PkgPresent(
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
+ 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
@@ -668,17 +687,17 @@ Tcl_PkgPresent(
return Tcl_PkgPresentEx(interp, name, version, exact, NULL);
}
-CONST char *
+const char *
Tcl_PkgPresentEx(
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
+ 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
+ void *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. */
@@ -691,24 +710,31 @@ Tcl_PkgPresentEx(
if (hPtr) {
pkgPtr = 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 by
* calling Tcl_PkgRequireEx() to check for us.
*/
- return Tcl_PkgRequireEx(interp, name, version, exact,
- clientDataPtr);
+ const char *foundVersion = Tcl_PkgRequireEx(interp, name, version,
+ exact, clientDataPtr);
+
+ if (foundVersion == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
+ NULL);
+ }
+ return foundVersion;
}
}
if (version != NULL) {
- Tcl_AppendResult(interp, "package ", name, " ", version,
- " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s %s is not present", name, version));
} else {
- Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "package %s is not present", name));
}
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
}
@@ -735,9 +761,9 @@ Tcl_PackageObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- static CONST char *pkgOptions[] = {
+ static const char *const pkgOptions[] = {
"forget", "ifneeded", "names", "prefer", "present",
"provide", "require", "unknown", "vcompare", "versions",
"vsatisfies", NULL
@@ -754,11 +780,12 @@ Tcl_PackageObjCmd(
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
- CONST char *version;
- char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL;
+ const char *version;
+ const char *argv2, *argv3, *argv4;
+ char *iva = NULL, *ivb = NULL;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
@@ -768,7 +795,7 @@ Tcl_PackageObjCmd(
}
switch ((enum pkgOptions) optionIndex) {
case PKG_FORGET: {
- char *keyString;
+ const char *keyString;
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
@@ -784,11 +811,11 @@ Tcl_PackageObjCmd(
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
+ Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ ckfree(availPtr);
}
- ckfree((char *) pkgPtr);
+ ckfree(pkgPtr);
}
break;
}
@@ -819,7 +846,6 @@ Tcl_PackageObjCmd(
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
-
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
ckfree(argv3i);
@@ -832,10 +858,11 @@ Tcl_PackageObjCmd(
if (res == 0){
if (objc == 4) {
ckfree(argv3i);
- Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
break;
}
}
@@ -845,7 +872,7 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
if (availPtr == NULL) {
- availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+ availPtr = ckalloc(sizeof(PkgAvail));
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -864,18 +891,25 @@ Tcl_PackageObjCmd(
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 = Tcl_GetHashValue(hPtr);
- if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
- Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
+ } else {
+ Tcl_Obj *resultObj;
+
+ resultObj = Tcl_NewObj();
+ tablePtr = &iPtr->packageTable;
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ pkgPtr = Tcl_GetHashValue(hPtr);
+ if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
+ Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
+ Tcl_GetHashKey(tablePtr, hPtr), -1));
+ }
}
+ Tcl_SetObjResult(interp, resultObj);
}
break;
case PKG_PRESENT: {
const char *name;
+
if (objc < 3) {
goto require;
}
@@ -915,7 +949,7 @@ Tcl_PackageObjCmd(
version = TclGetString(objv[3]);
}
}
- Tcl_PkgPresent(interp, name, version, exact);
+ Tcl_PkgPresentEx(interp, name, version, exact, NULL);
return TCL_ERROR;
break;
}
@@ -930,7 +964,8 @@ Tcl_PackageObjCmd(
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
- Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(pkgPtr->version, -1));
}
}
return TCL_OK;
@@ -939,13 +974,13 @@ Tcl_PackageObjCmd(
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_PkgProvide(interp, argv2, argv3);
+ return Tcl_PkgProvideEx(interp, argv2, argv3, NULL);
case PKG_REQUIRE:
require:
if (objc < 3) {
requireSyntax:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-exact? package ?requirement...?");
+ "?-exact? package ?requirement ...?");
return TCL_ERROR;
}
@@ -992,7 +1027,8 @@ Tcl_PackageObjCmd(
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
- Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
@@ -1011,7 +1047,7 @@ Tcl_PackageObjCmd(
break;
}
case PKG_PREFER: {
- static CONST char *pkgPreferOptions[] = {
+ static const char *const pkgPreferOptions[] = {
"latest", "stable", NULL
};
@@ -1080,23 +1116,27 @@ Tcl_PackageObjCmd(
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
- }
- argv2 = TclGetString(objv[2]);
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
- if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
- for (availPtr = pkgPtr->availPtr; availPtr != NULL;
- availPtr = availPtr->nextPtr) {
- Tcl_AppendElement(interp, availPtr->version);
+ } else {
+ Tcl_Obj *resultObj = Tcl_NewObj();
+
+ argv2 = TclGetString(objv[2]);
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ if (hPtr != NULL) {
+ pkgPtr = Tcl_GetHashValue(hPtr);
+ for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+ availPtr = availPtr->nextPtr) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(availPtr->version, -1));
+ }
}
+ Tcl_SetObjResult(interp, resultObj);
}
break;
case PKG_VSATISFIES: {
char *argv2i = NULL;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "version requirement requirement...");
+ Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?");
return TCL_ERROR;
}
@@ -1141,7 +1181,7 @@ Tcl_PackageObjCmd(
static Package *
FindPackage(
Tcl_Interp *interp, /* Interpreter to use for package lookup. */
- CONST char *name) /* Name of package to fine. */
+ const char *name) /* Name of package to fine. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
@@ -1150,7 +1190,7 @@ FindPackage(
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
- pkgPtr = (Package *) ckalloc(sizeof(Package));
+ pkgPtr = ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
@@ -1196,11 +1236,11 @@ TclFreePackageInfo(
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
+ Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ ckfree(availPtr);
}
- ckfree((char *) pkgPtr);
+ ckfree(pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
@@ -1231,13 +1271,13 @@ TclFreePackageInfo(
static int
CheckVersionAndConvert(
Tcl_Interp *interp, /* Used for error reporting. */
- CONST char *string, /* Supposedly a version number, which is
+ const char *string, /* Supposedly a version number, which is
* groups of decimal digits separated by
* dots. */
char **internal, /* Internal normalized representation */
int *stable) /* Flag: Version is (un)stable. */
{
- CONST char *p = string;
+ const char *p = string;
char prevChar;
int hasunstable = 0;
/*
@@ -1322,8 +1362,9 @@ CheckVersionAndConvert(
error:
ckfree(ibuf);
- Tcl_AppendResult(interp, "expected version number but got \"", string,
- "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected version number but got \"%s\"", string));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
@@ -1485,7 +1526,10 @@ CompareVersions(
if (*s1 != 0) {
s1++;
} else if (*s2 == 0) {
- /* s1, s2 both at the end => identical */
+ /*
+ * s1, s2 both at the end => identical
+ */
+
res = 0;
break;
}
@@ -1524,7 +1568,7 @@ static int
CheckAllRequirements(
Tcl_Interp *interp,
int reqc, /* Requirements to check. */
- Tcl_Obj *CONST reqv[])
+ Tcl_Obj *const reqv[])
{
int i;
@@ -1557,7 +1601,7 @@ CheckAllRequirements(
static int
CheckRequirement(
Tcl_Interp *interp, /* Used for error reporting. */
- CONST char *string) /* Supposedly a requirement. */
+ const char *string) /* Supposedly a requirement. */
{
/*
* Syntax of requirement = version
@@ -1570,7 +1614,7 @@ CheckRequirement(
dash = strchr(string, '-');
if (dash == NULL) {
/*
- * no dash found, has to be a simple version.
+ * No dash found, has to be a simple version.
*/
return CheckVersionAndConvert(interp, string, NULL, NULL);
@@ -1581,15 +1625,17 @@ CheckRequirement(
* More dashes found after the first. This is wrong.
*/
- Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
- string, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected versionMin-versionMax but got \"%s\"", string));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
return TCL_ERROR;
}
/*
* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
- * be empty.
+ * be empty. Also note that the string allocated with strdup() must be
+ * freed with free() and not ckfree().
*/
DupString(buf, string);
@@ -1629,22 +1675,20 @@ AddRequirementsToResult(
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
- Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version
+ Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+ int i, length;
- for (i = 0; i < reqc; i++) {
- int length;
- char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ for (i = 0; i < reqc; i++) {
+ const char *v = Tcl_GetStringFromObj(reqv[i], &length);
- if ((length & 0x1) && (v[length/2] == '-')
- && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
- Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
- } else {
- Tcl_AppendResult(interp, " ", v, NULL);
- }
+ if ((length & 0x1) && (v[length/2] == '-')
+ && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+ Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
+ } else {
+ Tcl_AppendPrintfToObj(result, " %s", v);
}
}
}
@@ -1670,18 +1714,18 @@ AddRequirementsToDString(
Tcl_DString *dsPtr,
int reqc, /* Requirements constraining the desired
* version. */
- Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version
+ Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
- if (reqc > 0) {
- int i;
+ int i;
+ if (reqc > 0) {
for (i = 0; i < reqc; i++) {
- Tcl_DStringAppend(dsPtr, " ", 1);
- Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1);
+ TclDStringAppendLiteral(dsPtr, " ");
+ TclDStringAppendObj(dsPtr, reqv[i]);
}
} else {
- Tcl_DStringAppend(dsPtr, " 0-", -1);
+ TclDStringAppendLiteral(dsPtr, " 0-");
}
}
@@ -1710,7 +1754,7 @@ SomeRequirementSatisfied(
* requirements. */
int reqc, /* Requirements constraining the desired
* version. */
- Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version
+ Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
int i;
@@ -1745,7 +1789,7 @@ static int
RequirementSatisfied(
char *havei, /* Version string, of candidate package we
* have. */
- CONST char *req) /* Requirement string the candidate has to
+ const char *req) /* Requirement string the candidate has to
* satisfy. */
{
/*
@@ -1843,23 +1887,25 @@ RequirementSatisfied(
*----------------------------------------------------------------------
*/
-CONST char *
+const char *
Tcl_PkgInitStubsCheck(
Tcl_Interp *interp,
- CONST char * version,
+ const char * version,
int exact)
{
- CONST char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
+ const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
if (exact && actualVersion) {
- CONST char *p = version;
+ const char *p = version;
int count = 0;
while (*p) {
- count += !isdigit(*p++);
+ count += !isdigit(UCHAR(*p++));
}
if (count == 1) {
if (0 != strncmp(version, actualVersion, strlen(version))) {
+ /* Construct error message */
+ Tcl_PkgPresent(interp, "Tcl", version, 1);
return NULL;
}
} else {
generated by cgit v0.12 at 2025-11-01 08:38:29 (GMT)