diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | doc/interp.n | 40 | ||||
| -rw-r--r-- | doc/tclvars.n | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 11 | ||||
| -rw-r--r-- | generic/tclExecute.c | 12 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclInterp.c | 125 | ||||
| -rw-r--r-- | tests/info.test | 143 | ||||
| -rw-r--r-- | tests/interp.test | 54 |
9 files changed, 352 insertions, 57 deletions
@@ -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-10 Andreas Kupries <andreask@activestate.com> * changes: Updates for 8.6b2 release. diff --git a/doc/interp.n b/doc/interp.n index 2d2330b..f0b4efd 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -6,7 +6,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.44 2010/01/20 13:42:17 dkf Exp $ +'\" RCS: @(#) $Id: interp.n,v 1.45 2010/11/15 21:34:54 andreas_kupries Exp $ '\" .so man.macros .TH interp n 8.6 Tcl "Tcl Built-In Commands" @@ -186,6 +186,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 diff --git a/doc/tclvars.n b/doc/tclvars.n index 792d5c8..32d4b08 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.42 2010/01/14 11:47:09 dkf Exp $ +'\" RCS: @(#) $Id: tclvars.n,v 1.43 2010/11/15 21:34:54 andreas_kupries Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" @@ -101,6 +101,11 @@ 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 fa63953..7fae8b3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.468 2010/10/20 20:52:26 ferrieux Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.469 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" @@ -596,6 +596,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 diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a8b408e..884c7d5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.509 2010/10/20 20:52:28 ferrieux Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.510 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2120,7 +2120,9 @@ TEBCresume( NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; @@ -2797,8 +2799,10 @@ TEBCresume( 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(); diff --git a/generic/tclInt.h b/generic/tclInt.h index c4ab6b3..218c40b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * 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.485 2010/10/20 20:52:28 ferrieux Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.486 2010/11/15 21:34:54 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -2253,6 +2253,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. @@ -2278,6 +2281,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 e22133a..6ccde87 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.113 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.114 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" @@ -210,6 +210,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, @@ -561,16 +564,18 @@ Tcl_InterpObjCmd( int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "delete", "eval", "exists", - "expose", "hide", "hidden", "issafe", + "create", "debug", "delete", + "eval", "exists", "expose", + "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", "slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_CREATE, 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 }; @@ -784,6 +789,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; @@ -2376,14 +2398,16 @@ SlaveObjCmd( Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { - "alias", "aliases", "bgerror", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + "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_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + 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 }; if (slaveInterp == NULL) { @@ -2428,6 +2452,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 ...?"); @@ -2591,6 +2625,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_FRAME 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 fd126a7..8c37f6d 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.78 2010/08/03 20:15:53 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.79 2010/11/15 21:34:54 andreas_kupries Exp $ if {{::tcltest} ni [namespace children]} { package require tcltest 2 @@ -690,14 +690,12 @@ 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 reported # command. The latter is required because otherwise the whole 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 @@ -1363,14 +1363,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 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -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 1369 file info.test cmd etrace proc ::tcltest::RunTest} -* {type source line 1367 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} -cleanup {unset y} +# 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 { @@ -1383,15 +1383,15 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -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 1389 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1387 file info.test cmd control proc ::tcltest::RunTest}} -cleanup {unset y} +# 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 @@ -1401,13 +1401,13 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo * {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} * {type source line 1397 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 1344 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1342 file info.test cmd control proc ::datal level 1} -* {type source line 1405 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. + + + + + + testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { @@ -1543,18 +1543,18 @@ test info-30.12 {bs+nl in computed word, nested eval} -body { } -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { - uplevel #0 { + subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ [reduce [info frame 0]];# line 1550 } } - return $res -} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + set res }] ; interp delete sub ; set res +} -cleanup {unset res} -result {type source line 1550 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 { @@ -1562,7 +1562,7 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} { [reduce [info frame 0]]";# line 1562 }] rename abra {} - set res + set res }] ; interp delete sub ; set res } { type source line 1562 file info.test cmd {info frame 0} proc ::abra} test info-30.15 {bs+nl in literal words, nested proc body, compiled} { @@ -1879,6 +1879,83 @@ test info-39.1 {location information not confused by literal sharing, bug 293308 type source line 1859 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 1890 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1902 file info.test cmd etrace proc ::control} +* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1900 file info.test cmd control proc ::datal level 1} +* {type source line 1905 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 1919 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1930 file info.test cmd etrace proc ::control} +* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1928 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 1944 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1951 file info.test cmd etrace level 1} +* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup diff --git a/tests/interp.test b/tests/interp.test index 45254ad..f73fe49 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.68 2009/12/29 14:55:42 dkf Exp $ +# RCS: @(#) $Id: interp.test,v 1.69 2010/11/15 21:34:54 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} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { } -result {wrong # args: should be "interp slaves ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -3596,6 +3596,50 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { unset result 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] { |