summaryrefslogtreecommitdiffstats
path: root/generic/tclTestProcBodyObj.c
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2019-03-07 20:24:53 (GMT)
committerdgp <dgp@users.sourceforge.net>2019-03-07 20:24:53 (GMT)
commit15ff4cc2de2b5ab6775ba2f815eaf36b4c6a0c26 (patch)
tree6f60828c6433c60689c33507c1ba06c089b3ddff /generic/tclTestProcBodyObj.c
parent7ca040ad884baacea75bb242383440f3ce80e0bb (diff)
parent68061dfef2a2d216cd2e4c7bbe169e6f05fece70 (diff)
downloadtcl-15ff4cc2de2b5ab6775ba2f815eaf36b4c6a0c26.zip
tcl-15ff4cc2de2b5ab6775ba2f815eaf36b4c6a0c26.tar.gz
tcl-15ff4cc2de2b5ab6775ba2f815eaf36b4c6a0c26.tar.bz2
Integrate the test, which seems to indicate the bug fix doesn't work.
More to come....
Diffstat (limited to 'generic/tclTestProcBodyObj.c')
-rw-r--r--generic/tclTestProcBodyObj.c49
1 files changed, 48 insertions, 1 deletions
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 4d32c5a..de1fa52 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,48 @@ 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);
+fprintf(stdout, "CHECK %p '%s' %p '%s'\n", version, version,
+packageVersion, packageVersion); fflush(stdout);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ strcmp(version, packageVersion) == 0));
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4