aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/tcl/generic/tclTest.c')
-rw-r--r--contrib/tcl/generic/tclTest.c128
1 files changed, 112 insertions, 16 deletions
diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c
index ecc2abfdd429..80cfb9c40cc3 100644
--- a/contrib/tcl/generic/tclTest.c
+++ b/contrib/tcl/generic/tclTest.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26
+ * SCCS: @(#) tclTest.c 1.119 97/10/31 15:57:28
*/
#define TCL_TEST
@@ -59,6 +59,13 @@ static TestAsyncHandler *firstHandler = NULL;
static Tcl_DString dstring;
/*
+ * The command trace below is used by the "testcmdtraceCmd" command
+ * to test the command tracing facilities.
+ */
+
+static Tcl_Trace cmdTrace;
+
+/*
* One of the following structures exists for each command created
* by TestdelCmd:
*/
@@ -84,6 +91,11 @@ static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+static void CmdTraceDeleteProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int level, char *command, Tcl_CmdProc *cmdProc,
+ ClientData cmdClientData, int argc,
+ char **argv));
static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
@@ -167,6 +179,9 @@ static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
int objc, Tcl_Obj *CONST objv[]));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestsetrecursionlimitCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
@@ -274,6 +289,9 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testsetrecursionlimit",
+ TestsetrecursionlimitCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
@@ -661,28 +679,42 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
- Tcl_Trace trace;
Tcl_DString buffer;
int result;
- if (argc != 2) {
+ if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " script\"", (char *) NULL);
+ " option script\"", (char *) NULL);
return TCL_ERROR;
}
- Tcl_DStringInit(&buffer);
- trace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
-
- result = Tcl_Eval(interp, argv[1]);
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ if (strcmp(argv[1], "tracetest") == 0) {
+ Tcl_DStringInit(&buffer);
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ result = Tcl_Eval(interp, argv[2]);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ }
+ Tcl_DeleteTrace(interp, cmdTrace);
+ Tcl_DStringFree(&buffer);
+ } else if (strcmp(argv[1], "deletetest") == 0) {
+ /*
+ * Create a command trace then eval a script to check whether it is
+ * called. Note that this trace procedure removes itself as a
+ * further check of the robustness of the trace proc calling code in
+ * TclExecuteByteCode.
+ */
+
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
+ result = Tcl_Eval(interp, argv[2]);
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argv[1],
+ "\": must be tracetest or deletetest", (char *) NULL);
+ return TCL_ERROR;
}
-
- Tcl_DeleteTrace(interp, trace);
- Tcl_DStringFree(&buffer);
return TCL_OK;
}
@@ -713,6 +745,29 @@ CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
}
Tcl_DStringEndSublist(bufPtr);
}
+
+static void
+CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
+ cmdClientData, argc, argv)
+ ClientData clientData; /* Unused. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int level; /* Current trace level. */
+ char *command; /* The command being traced (after
+ * substitutions). */
+ Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
+ ClientData cmdClientData; /* Client data associated with command
+ * procedure. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ /*
+ * Remove ourselves to test whether calling Tcl_DeleteTrace within
+ * a trace callback causes the for loop in TclExecuteByteCode that
+ * calls traces to reference freed memory.
+ */
+
+ Tcl_DeleteTrace(interp, cmdTrace);
+}
/*
*----------------------------------------------------------------------
@@ -1794,6 +1849,47 @@ TestsetplatformCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestsetrecursionlimitCmd --
+ *
+ * This procedure implements the "testsetrecursionlimit" command. It is
+ * used to change the interp recursion limit (to test the effects
+ * of Tcl_SetRecursionLimit).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Sets the interp's recursion limit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetrecursionlimitCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int value;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "integer");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ value = Tcl_SetRecursionLimit(interp, value);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), value);
+ return TCL_OK;
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
@@ -2164,7 +2260,7 @@ TestchmodCmd(dummy, interp, argc, argv)
}
mode = (int) strtol(argv[1], &rest, 8);
- if (*rest != '\0') {
+ if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}