Attachment "infoframe.patch" to
ticket [1503647fff]
added by
dgp
2006-06-10 01:22:10.
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.86
diff -u -r1.86 tclCmdIL.c
--- generic/tclCmdIL.c 9 Dec 2005 14:13:00 -0000 1.86
+++ generic/tclCmdIL.c 9 Jun 2006 18:15:28 -0000
@@ -114,6 +114,8 @@
int objc, Tcl_Obj *CONST objv[]);
static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
+static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
@@ -358,15 +360,15 @@
{
static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
- "complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded",
+ "complete", "default", "exists", "frame", "functions",
+ "globals", "hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
- ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
- IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
+ ICompleteIdx, IDefaultIdx, IExistsIdx, IFrameIdx, IFunctionsIdx,
+ IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
@@ -405,6 +407,9 @@
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
+ case IFrameIdx:
+ result = InfoFrameCmd(clientData, interp, objc, objv);
+ break;
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
@@ -1073,6 +1078,72 @@
/*
*----------------------------------------------------------------------
*
+ * InfoFrameCmd --
+ *
+ * Called to implement the "info frame" command that returns information
+ * about the stack of CallFrames. Handles the following syntax:
+ *
+ * info frame ?number?
+ *
+ * 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
+InfoFrameCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int level, currentLevel = 0;
+ CallFrame *framePtr = iPtr->framePtr;
+ Tcl_Obj *listPtr;
+
+ while (framePtr != NULL) {
+ currentLevel++;
+ framePtr = framePtr->callerPtr;
+ }
+
+ if (objc == 2) { /* just "info level" */
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(currentLevel));
+ return TCL_OK;
+ } else if (objc == 3) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level > 0) {
+ level -= currentLevel;
+ }
+ level *= -1;
+ if ((level < 0) || (level > currentLevel)) {
+ Tcl_AppendResult(interp, "bad level \"",
+ TclGetString(objv[2]), "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ framePtr = iPtr->framePtr;
+ while (level--) {
+ framePtr = framePtr->callerPtr;
+ }
+ listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ }
+
+ Tcl_WrongNumArgs(interp, 2, objv, "?number?");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* InfoFunctionsCmd --
*
* Called to implement the "info functions" command that returns the list
Index: tests/info.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/info.test,v
retrieving revision 1.35
diff -u -r1.35 info.test
--- tests/info.test 6 Apr 2006 18:19:26 -0000 1.35
+++ tests/info.test 9 Jun 2006 18:15:32 -0000
@@ -647,16 +647,16 @@
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} {
list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} {
list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} {
list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
