diff options
author | dgp <dgp@users.sourceforge.net> | 2019-03-07 20:24:53 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2019-03-07 20:24:53 (GMT) |
commit | 15ff4cc2de2b5ab6775ba2f815eaf36b4c6a0c26 (patch) | |
tree | 6f60828c6433c60689c33507c1ba06c089b3ddff /generic/tclTestProcBodyObj.c | |
parent | 7ca040ad884baacea75bb242383440f3ce80e0bb (diff) | |
parent | 68061dfef2a2d216cd2e4c7bbe169e6f05fece70 (diff) | |
download | tcl-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.c | 49 |
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 |