summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog11
-rw-r--r--doc/interp.n40
-rw-r--r--doc/tclvars.n39
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclExecute.c14
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclInterp.c109
-rw-r--r--tests/info.test143
-rw-r--r--tests/interp.test53
9 files changed, 377 insertions, 53 deletions
diff --git a/ChangeLog b/ChangeLog
index eb31a48..3fcedae 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2010-11-15 Andreas Kupries <andreask@activestate.com>
+
+ * doc/interp.n: [3081184] TIP #378.
+ * doc/tclvars.n: Performance fix for TIP #280.
+ * generic/tclBasic.c:
+ * generic/tclExecute.c:
+ * generic/tclInt.h:
+ * generic/tclInterp.c:
+ * tests/info.test:
+ * tests/interp.test:
+
2010-11-03 Kevin B. Kenny <kennykb@acm.org>
* generic/tclCompCmds.c (TclCompileCatchCmd):
diff --git a/doc/interp.n b/doc/interp.n
index 5612226..4eae0d6 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: interp.n,v 1.38 2007/12/13 15:22:32 dgp Exp $
+'\" RCS: @(#) $Id: interp.n,v 1.38.2.1 2010/11/15 21:32:31 andreas_kupries Exp $
'\"
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
@@ -168,6 +168,44 @@ given name already exists in this master.
The initial recursion limit of the slave interpreter is set to the
current recursion limit of its parent interpreter.
.TP
+\fBinterp\fR \fBdebug \fIpath\fR ?\fI\-frame\fR ?\fIbool\fR??
+.
+Controls whether frame-level stack information is captured in the
+slave interpreter identified by \fIpath\fR. If no arguments are
+given, option and current setting are returned. If \fI\-frame\fR
+is given, the debug setting is set to the given boolean if provided
+and the current setting is returned.
+This only effects the output of \fBinfo frame\fR, in that exact
+frame-level information for command invocation at the bytecode level
+is only captured with this setting on.
+.PP
+.RS
+For example, with code like
+.PP
+.CS
+\fBproc\fR mycontrol {... script} {
+ ...
+ \fBuplevel\fR 1 $script
+ ...
+}
+
+\fBproc\fR dosomething {...} {
+ ...
+ mycontrol {
+ somecode
+ }
+}
+.CE
+.PP
+the standard setting will provide a relative line number for the
+command \fBsomecode\fR and the relevant frame will be of type
+\fBeval\fR. With frame-debug active on the other hand the tracking
+extends so far that the system will be able to determine the file and
+absolute line number of this command, and return a frame of type
+\fBsource\fR. This more exact information is paid for with slower
+execution of all commands.
+.RE
+.TP
\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
Deletes zero or more interpreters given by the optional \fIpath\fR
arguments, and for each interpreter, it also deletes its slaves. The
diff --git a/doc/tclvars.n b/doc/tclvars.n
index cd5cc15..c294be8 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: tclvars.n,v 1.35 2007/12/13 15:22:33 dgp Exp $
+'\" RCS: @(#) $Id: tclvars.n,v 1.35.2.1 2010/11/15 21:32:31 andreas_kupries Exp $
'\"
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
@@ -49,6 +49,43 @@ Tcl are left unmodified. Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
will not work on Windows and is discouraged for cross-platform usage.
+.PP
+The following elements of \fBenv\fR are special to Tcl:
+.TP
+\fBenv(HOME)\fR
+.
+This environment variable, if set, gives the location of the directory
+considered to be the current user's home directory, and to which a
+call of \fBcd\fR without arguments or with just
+.QW ~
+as an argument will change into. Most platforms set this correctly by
+default; it does not normally need to be set by user code.
+.TP
+\fBenv(TCL_LIBRARY)\fR
+.
+If set, then it specifies the location of the directory containing
+library scripts (the value of this variable will be
+assigned to the \fBtcl_library\fR variable and therefore returned by
+the command \fBinfo library\fR). If this variable is not set then
+a default value is used.
+.RS
+.PP
+Note that this environment variable should \fInot\fR normally be set.
+.RE
+.TP
+\fBenv(TCLLIBPATH)\fR
+.
+If set, then it must contain a valid Tcl list giving directories to
+search during auto-load operations. Directories must be specified in
+Tcl format, using
+.QW /
+as the path separator, regardless of platform.
+This variable is only used when initializing the \fBauto_path\fR variable.
+.TP
+\fBenv(TCL_INTERP_DEBUG_FRAME)\fR
+.
+If existing, it has the same effect as running \fBinterp debug {} -frame 1\fR
+as the very first command of each new Tcl interpreter.
.RE
.TP
\fBerrorCode\fR
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0c57652..e686237 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.295.2.18 2010/07/25 10:13:49 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.295.2.19 2010/11/15 21:32:31 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -501,6 +501,15 @@ Tcl_CreateInterp(void)
iPtr->resultSpace[0] = 0;
iPtr->threadId = Tcl_GetCurrentThread();
+ /* TIP #378 */
+#ifdef TCL_INTERP_DEBUG_FRAME
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+#else
+ if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+ }
+#endif
+
/*
* Initialise the tables for variable traces and searches *before*
* creating the global ns - so that the trace on errorInfo can be
@@ -3442,7 +3451,9 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
+#if !defined(TCL_NO_STACK_CHECK)
int localInt; /* used for checking the stack */
+#endif
register Interp *iPtr = (Interp *) interp;
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d70fcba..2f38758 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.369.2.18 2010/10/09 16:31:28 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.369.2.19 2010/11/15 21:32:31 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2412,14 +2412,18 @@ TclExecuteByteCode(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
- TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
DECACHE_STACK_INFO();
result = TclEvalObjvInternal(interp, objc, objv,
/* call from TEBC */(char *) -1, -1, 0);
CACHE_STACK_INFO();
- TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc,
- codePtr, pc - codePtr->codeStart);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, pc - codePtr->codeStart);
+ }
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
if (result == TCL_OK) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index eb88ef0..31c9628 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,12 +13,14 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.362.2.14 2010/07/25 10:13:48 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.362.2.15 2010/11/15 21:32:32 andreas_kupries Exp $
*/
#ifndef _TCLINT
#define _TCLINT
+#define TCL_NO_STACK_CHECK /* DISABLE C RUNTIME STACK CHECK - Test AIX */
+
/*
* Some numerics configuration options.
*/
@@ -2032,6 +2034,9 @@ typedef struct InterpList {
* SAFE_INTERP: Non zero means that the current interp is a safe
* interp (i.e. it has only the safe commands installed,
* less priviledge than a regular interp).
+ * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter
+ * debug/info mechanisms (e.g. info frame eval/uplevel
+ * tracing) which are performance intensive.
* INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
* active; so no further trace callbacks should be
* invoked.
@@ -2047,6 +2052,7 @@ typedef struct InterpList {
#define DELETED 1
#define ERR_ALREADY_LOGGED 4
+#define INTERP_DEBUG_FRAME 0x10
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
#define SAFE_INTERP 0x80
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index e7ad80d..219b059 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.83.2.4 2009/12/29 13:13:18 dkf Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.83.2.5 2010/11/15 21:32:32 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -207,6 +207,9 @@ static int SlaveBgerror(Tcl_Interp *interp,
Tcl_Obj *const objv[]);
static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int safe);
+static int SlaveDebugCmd(Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp,
+ int objc, Tcl_Obj *const objv[]);
static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
int objc, Tcl_Obj *const objv[]);
static int SlaveExpose(Tcl_Interp *interp,
@@ -558,7 +561,7 @@ Tcl_InterpObjCmd(
int index;
static const char *options[] = {
"alias", "aliases", "bgerror", "create",
- "delete", "eval", "exists", "expose",
+ "debug", "delete", "eval", "exists", "expose",
"hide", "hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit","slaves",
"share", "target", "transfer",
@@ -566,7 +569,7 @@ Tcl_InterpObjCmd(
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE,
- OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
+ OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES,
OPT_SHARE, OPT_TARGET, OPT_TRANSFER
@@ -706,6 +709,23 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, slavePtr);
return TCL_OK;
}
+ case OPT_DEBUG: {
+ /* TIP #378 */
+ Tcl_Interp *slaveInterp;
+
+ /*
+ * Currently only -frame supported, otherwise ?-option ?value??
+ */
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
+ }
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
@@ -2228,12 +2248,12 @@ SlaveObjCmd(
Tcl_Interp *slaveInterp = clientData;
int index;
static const char *options[] = {
- "alias", "aliases", "bgerror", "eval",
+ "alias", "aliases", "bgerror", "debug", "eval",
"expose", "hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit", NULL
};
enum options {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL,
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL,
OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT
};
@@ -2280,6 +2300,16 @@ SlaveObjCmd(
return TCL_ERROR;
}
return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
+ case OPT_DEBUG:
+ /*
+ * TIP #378 *
+ * Currently only -frame supported, otherwise ?-option ?value? ...?
+ */
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??");
+ return TCL_ERROR;
+ }
+ return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2);
case OPT_EVAL:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
@@ -2443,6 +2473,75 @@ SlaveObjCmdDeleteProc(
/*
*----------------------------------------------------------------------
*
+ * SlaveDebugCmd -- TIP #378
+ *
+ * Helper function to handle 'debug' command in a slave interpreter.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May modify INTERP_DEBUG flag in the slave.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SlaveDebugCmd(
+ Tcl_Interp *interp, /* Interp for error return. */
+ Tcl_Interp *slaveInterp, /* The slave interpreter in which command
+ * will be evaluated. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *const debugTypes[] = {
+ "-frame", NULL
+ };
+ enum DebugTypes {
+ DEBUG_TYPE_FRAME
+ };
+ int debugType;
+ Interp *iPtr;
+ Tcl_Obj *resultPtr;
+
+ iPtr = (Interp *) slaveInterp;
+ if (objc == 0) {
+ resultPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewStringObj("-frame", -1));
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
+ Tcl_SetObjResult(interp, resultPtr);
+ } else {
+ if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes,
+ "debug option", 0, &debugType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (debugType == DEBUG_TYPE_FRAME) {
+ if (objc == 2) { /* set */
+ if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /*
+ * Quietly ignore attempts to disable interp debugging.
+ * This is a one-way switch as frame debug info is maintained
+ * in a stack that must be consistent once turned on.
+ */
+ if (debugType) {
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+ }
+ }
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* SlaveEval --
*
* Helper function to evaluate a command in a slave interpreter.
diff --git a/tests/info.test b/tests/info.test
index b668669..dbf9b18 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.47.2.12 2010/08/03 16:50:49 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.47.2.13 2010/11/15 21:32:32 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -689,7 +689,6 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
##
# ### ### ### ######### ######### #########
## info frame
-
## Helper
# For the more complex results we cut the file name down to remove
# path dependencies, and we use only part of the first line of the
@@ -697,7 +696,6 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
# test case may appear in some results, but the result is part of the
# testcase. An infinite string would be required to describe that. The
# cutting-down breaks this.
-
proc reduce {frame} {
set pos [lsearch -exact $frame cmd]
incr pos
@@ -714,7 +712,9 @@ proc reduce {frame} {
}
set frame
}
-
+proc subinterp {} { interp create sub ; interp debug sub -frame 1;
+ interp eval sub [list proc reduce [info args reduce] [info body reduce]]
+}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
@@ -1364,14 +1364,14 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1362 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}}
-test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body {
- join [lrange [uplevel \#0 {
- set y DL.
- etrace
- }] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1370 file info.test cmd etrace proc ::tcltest::RunTest}
-* {type source line 1368 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}}
+# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
set script {
@@ -1384,15 +1384,15 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1381 file info.test cmd {control y $script} proc ::tcltest::RunTest}}
-test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body {
- join [lrange [control y {
- set y DPL
- etrace
- }] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1390 file info.test cmd etrace proc ::control}
-* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1388 file info.test cmd control proc ::tcltest::RunTest}}
+# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
+
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
@@ -1402,13 +1402,13 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo
* {type source line 1354 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1398 file info.test cmd datav proc ::tcltest::RunTest}}
-test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body {
- join [lrange [datal] 0 4] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1345 file info.test cmd etrace proc ::control}
-* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1343 file info.test cmd control proc ::datal level 1}
-* {type source line 1406 file info.test cmd datal proc ::tcltest::RunTest}}
+# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
# -------------------------------------------------------------------------
# literal sharing
@@ -1536,26 +1536,26 @@ test info-30.12 {bs+nl in computed word, nested eval} {
} { type source line 1534 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.13 {bs+nl in literal words, uplevel script, with nested words} {
- uplevel #0 {
+ subinterp ; set res [interp eval sub { uplevel #0 {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1543
}
}
- set res
-} {type source line 1543 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+ set res }] ; interp delete sub ; set res
+} {type source line 1543 file info.test cmd {info frame 0} level 0}
test info-30.14 {bs+nl, literal word, uplevel through proc} {
- proc abra {script} {
+ subinterp ; set res [interp eval sub { proc abra {script} {
uplevel 1 $script
}
set res [abra {
return "\
-[reduce [info frame 0]]";# line 1555
+ [reduce [info frame 0]]";# line 1555
}]
rename abra {}
- set res
+ set res }] ; interp delete sub ; set res
} { type source line 1555 file info.test cmd {info frame 0} proc ::abra}
test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
@@ -1742,6 +1742,81 @@ test info-39.1 {location information not confused by literal sharing, bug 293308
type source line 1722 file info.test cmd print_one proc ::test_info_frame level 1}
# -------------------------------------------------------------------------
+# Tests moved to the end to not disturb other tests and their locations.
+
+test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ proc control {vv script} {
+ upvar 1 $vv var
+ return [uplevel 1 $script]
+ }
+ proc datal {} {
+ control y {
+ set y PPL
+ etrace
+ }
+ }
+ join [lrange [datal] 0 4] \n
+ }
+} -result {* {type source line 1753 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1765 file info.test cmd etrace proc ::control}
+* {type source line 1760 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1763 file info.test cmd control proc ::datal level 1}
+* {type source line 1768 file info.test cmd datal level 2}} -cleanup {interp delete sub}
+
+test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ proc control {vv script} {
+ upvar 1 $vv var
+ return [uplevel 1 $script]
+ }
+ join [lrange [control y {
+ set y DPL
+ etrace
+ }] 0 3] \n
+ }
+} -result {* {type source line 1782 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1793 file info.test cmd etrace proc ::control}
+* {type source line 1789 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1791 file info.test cmd control level 1}} -cleanup {interp delete sub}
+
+test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ join [lrange [uplevel \#0 {
+ set y DL.
+ etrace
+ }] 0 2] \n
+ }
+} -result {* {type source line 1807 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1814 file info.test cmd etrace level 1}
+* {type source line 1812 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
diff --git a/tests/interp.test b/tests/interp.test
index 3a0c6a5..224ec11 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.54.2.3 2009/12/29 13:13:18 dkf Exp $
+# RCS: @(#) $Id: interp.test,v 1.54.2.4 2010/11/15 21:32:32 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} {
} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
test interp-1.2 {options for interp command} {
list [catch {interp frobox} msg] $msg
-} {1 {bad option "frobox": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "frobox": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.3 {options for interp command} {
interp delete
} ""
@@ -49,13 +49,13 @@ test interp-1.6 {options for interp command} {
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-1.7 {options for interp command} {
list [catch {interp hello} msg] $msg
-} {1 {bad option "hello": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "hello": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.8 {options for interp command} {
list [catch {interp -froboz} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.9 {options for interp command} {
list [catch {interp -froboz -safe} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.10 {options for interp command} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
@@ -3503,6 +3503,49 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
interp delete a
} -result {26 26}
+test interp-38.1 {interp debug one-way switch} -setup {
+ catch {interp delete a}
+ interp create a
+ interp debug a -frame 1
+} -body {
+ # TIP #3xx interp debug frame is a one-way switch
+ interp debug a -frame 0
+} -cleanup {
+ interp delete a
+} -result {1}
+test interp-38.2 {interp debug env var} -setup {
+ catch {interp delete a}
+ set ::env(TCL_INTERP_DEBUG_FRAME) 1
+ interp create a
+} -body {
+ interp debug a
+} -cleanup {
+ unset ::env(TCL_INTERP_DEBUG_FRAME)
+ interp delete a
+} -result {-frame 1}
+test interp-38.3 {interp debug wrong args} -body {
+ interp debug
+} -returnCodes {
+ error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+test interp-38.4 {interp debug basic setup} -body {
+ interp debug {}
+} -result {-frame 0}
+test interp-38.5 {interp debug basic setup} -body {
+ interp debug {} -f
+} -result {0}
+test interp-38.6 {interp debug basic setup} -body {
+ interp debug -frames
+} -returnCodes error -result {could not find interpreter "-frames"}
+test interp-38.7 {interp debug basic setup} -body {
+ interp debug {} -frames
+} -returnCodes error -result {bad debug option "-frames": must be -frame}
+test interp-38.8 {interp debug basic setup} -body {
+ interp debug {} -frame 0 bogus
+} -returnCodes {
+ error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+
# cleanup
foreach i [interp slaves] {
interp delete $i
generated by cgit v0.12 at 2024-11-04 18:40:26 (GMT)