summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclPkg.c38
-rw-r--r--generic/tclTestProcBodyObj.c47
-rw-r--r--tests/proc.test3
3 files changed, 67 insertions, 21 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index d4080c2..c1e2078 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -40,10 +40,7 @@ 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. */
+ Tcl_Obj *version;
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
const void *clientData; /* Client data. */
@@ -150,12 +147,13 @@ Tcl_PkgProvideEx(
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
- DupString(pkgPtr->version, version);
+ pkgPtr->version = Tcl_NewStringObj(version, -1);
+ Tcl_IncrRefCount(pkgPtr->version);
pkgPtr->clientData = clientData;
return TCL_OK;
}
- if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
+ if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
@@ -175,7 +173,7 @@ Tcl_PkgProvideEx(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"conflicting versions provided for package \"%s\": %s, then %s",
- name, pkgPtr->version, version));
+ name, Tcl_GetString(pkgPtr->version), version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
@@ -318,7 +316,7 @@ Tcl_PkgRequireEx(
if (version == NULL) {
if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
- result = Tcl_GetStringResult(interp);
+ result = Tcl_GetString(Tcl_GetObjResult(interp));
Tcl_ResetResult(interp);
}
} else {
@@ -332,7 +330,7 @@ Tcl_PkgRequireEx(
}
Tcl_IncrRefCount(ov);
if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
- result = Tcl_GetStringResult(interp);
+ result = Tcl_GetString(Tcl_GetObjResult(interp));
Tcl_ResetResult(interp);
}
TclDecrRefCount(ov);
@@ -474,7 +472,8 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
*/
if (reqc != 0) {
- CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL);
+ CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
+ &pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
@@ -482,7 +481,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
if (!satisfies) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"version conflict for package \"%s\": have %s, need",
- name, reqPtr->pkgPtr->version));
+ name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
NULL);
AddRequirementsToResult(interp, reqc, reqv);
@@ -495,7 +494,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
*ptr = reqPtr->pkgPtr->clientData;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
+ Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
@@ -694,8 +693,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
} else {
char *pvi, *vi;
- if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
- NULL) != TCL_OK) {
+ if (TCL_OK != CheckVersionAndConvert(interp,
+ Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
result = TCL_ERROR;
} else if (CheckVersionAndConvert(interp,
versionToProvide, &vi, NULL) != TCL_OK) {
@@ -712,7 +711,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
"attempt to provide package %s %s failed:"
" package %s %s provided instead",
name, versionToProvide,
- name, reqPtr->pkgPtr->version));
+ name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
@@ -750,7 +749,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
*/
if (reqPtr->pkgPtr->version != NULL) {
- ckfree(reqPtr->pkgPtr->version);
+ Tcl_DecrRefCount(reqPtr->pkgPtr->version);
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
@@ -926,7 +925,7 @@ TclNRPackageObjCmd(
pkgPtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
+ Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
@@ -1084,8 +1083,7 @@ TclNRPackageObjCmd(
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj(pkgPtr->version, -1));
+ Tcl_SetObjResult(interp, pkgPtr->version);
}
}
return TCL_OK;
@@ -1378,7 +1376,7 @@ TclFreePackageInfo(
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
+ Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 4d32c5a..fba2844 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -21,13 +21,14 @@
*/
static const char packageName[] = "procbodytest";
-static const char packageVersion[] = "1.0";
+static const char packageVersion[] = "1.1";
/*
* Name of the commands exported by this package
*/
static const char procCommand[] = "proc";
+static const char checkCommand[] = "check";
/*
* this struct describes an entry in the table of command names and command
@@ -46,6 +47,8 @@ typedef struct CmdTable {
static int ProcBodyTestProcObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static int ProcBodyTestCheckObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
const char *namespace, const CmdTable *cmdTablePtr);
@@ -57,11 +60,13 @@ static int RegisterCommand(Tcl_Interp* interp,
static const CmdTable commands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
+ { checkCommand, ProcBodyTestCheckObjCmd, 1 },
{ 0, 0, 0 }
};
static const CmdTable safeCommands[] = {
{ procCommand, ProcBodyTestProcObjCmd, 1 },
+ { checkCommand, ProcBodyTestCheckObjCmd, 1 },
{ 0, 0, 0 }
};
@@ -301,6 +306,46 @@ ProcBodyTestProcObjCmd(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * ProcBodyTestCheckObjCmd --
+ *
+ * Implements the "procbodytest::check" command. Here is the command
+ * description:
+ * procbodytest::check
+ *
+ * Performs an internal check that the Tcl_PkgPresent() command returns
+ * the same version number as was registered when the procbodytest package
+ * was provided. Places a boolean in the interp result indicating the
+ * test outcome.
+ *
+ * Results:
+ * Returns a standard Tcl code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcBodyTestCheckObjCmd(
+ ClientData dummy, /* context; not used */
+ Tcl_Interp *interp, /* the current interpreter */
+ int objc, /* argument count */
+ Tcl_Obj *const objv[]) /* arguments */
+{
+ const char *version;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ strcmp(version, packageVersion) == 0));
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/tests/proc.test b/tests/proc.test
index 8b25b0a..9be056f 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -321,6 +321,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
rename getbytes {}
unset -nocomplain end i tmp leakedBytes
} -result 0
+test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
+ procbodytest::check
+} 1
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
proc p args {} ; # this will be bytecompiled into t
generated by cgit v0.12 at 2024-10-22 23:42:00 (GMT)