summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
authorferrieux <ferrieux@users.sourceforge.net>2009-11-16 17:38:08 (GMT)
committerferrieux <ferrieux@users.sourceforge.net>2009-11-16 17:38:08 (GMT)
commit3ffda83a5b3d9b03fa4bad1e5384919a46adf47a (patch)
tree1b93d42b56b88ab1862f7389658528282be889d6 /generic/tclCmdIL.c
parentd264119bd45f0b0e694574efc0a627ac1a4232cb (diff)
downloadtcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.zip
tcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.tar.gz
tcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.tar.bz2
(forward port) Fix [Bug 2891556] and improve test to detect similar manifestations in the future. Add tcltest support for finalization.
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c57
1 files changed, 56 insertions, 1 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 03f5593..9c89ae4 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.171 2009/08/20 10:56:55 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.172 2009/11/16 17:38:08 ferrieux Exp $
*/
#include "tclInt.h"
@@ -118,6 +118,9 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+/* TIP #348 - New 'info' subcommand 'errorstack' */
+static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
/* TIP #280 - New 'info' subcommand 'frame' */
static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -164,6 +167,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"complete", InfoCompleteCmd, NULL},
{"coroutine", TclInfoCoroutineCmd, NULL},
{"default", InfoDefaultCmd, NULL},
+ {"errorstack", InfoErrorStackCmd, NULL},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd},
{"frame", InfoFrameCmd, NULL},
{"functions", InfoFunctionsCmd, NULL},
@@ -1017,6 +1021,55 @@ InfoDefaultCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoErrorStackCmd --
+ *
+ * Called to implement the "info errorstack" command that returns information
+ * about the last error's call stack. Handles the following syntax:
+ *
+ * info errorstack ?interp?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoErrorStackCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Interp *target;
+ Interp *iPtr;
+
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ return TCL_ERROR;
+ }
+
+ target = interp;
+ if (objc == 2) {
+ target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ iPtr = (Interp *) target;
+ Tcl_SetObjResult(interp, iPtr->errorStack);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInfoExistsCmd --
*
* Called to implement the "info exists" command that determines whether
@@ -4388,5 +4441,7 @@ SelectObjFromSublist(
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/