Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | * 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: |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
61ddf0cf16296511b567e9206ac1b952 |
User & Date: | andreas_kupries 2010-11-15 21:34:54 |
Context
2010-11-16
| ||
14:03 | Bring compilation under mingw-w64 a bit closer to reality check-in: bef6da697c user: nijtmans tags: trunk | |
2010-11-15
| ||
21:34 | * doc/interp.n: [3081184] TIP #378. * doc/tclvars.n: Performance fix for TIP #280. * generic/tcl... check-in: 61ddf0cf16 user: andreas_kupries tags: trunk | |
10:12 | reverted previous commit: it has effect on the Windows console check-in: 6c8f8523b9 user: nijtmans tags: trunk | |
Changes
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2010-11-10 Andreas Kupries <[email protected]> * changes: Updates for 8.6b2 release. 2010-11-09 Donal K. Fellows <[email protected]> * generic/tclOOMethod.c (ProcedureMethodVarResolver): [Bug 3105999]: | > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | 2010-11-15 Andreas Kupries <[email protected]> * 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 <[email protected]> * changes: Updates for 8.6b2 release. 2010-11-09 Donal K. Fellows <[email protected]> * generic/tclOOMethod.c (ProcedureMethodVarResolver): [Bug 3105999]: |
︙ | ︙ |
Changes to doc/interp.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" Copyright (c) 2006-2008 Joe Mistachkin. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" Copyright (c) 2006-2008 Joe Mistachkin. '\" '\" 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.45 2010/11/15 21:34:54 andreas_kupries Exp $ '\" .so man.macros .TH interp n 8.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME interp \- Create and manipulate Tcl interpreters |
︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 193 194 | mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the new interpreter. The name of a slave interpreter must be unique among all the slaves for its master; an error occurs if a slave interpreter by the 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 \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 command also deletes the slave command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the new interpreter. The name of a slave interpreter must be unique among all the slaves for its master; an error occurs if a slave interpreter by the 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 command also deletes the slave command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name |
︙ | ︙ |
Changes to doc/tclvars.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" 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.43 2010/11/15 21:34:54 andreas_kupries Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceEval, tcl_wordchars, tcl_version \- Variables used by Tcl |
︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 | . 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. .RE .TP \fBerrorCode\fR . This variable holds the value of the \fB\-errorcode\fR return option set by the most recent error that occurred in this interpreter. This list value represents additional information about the error | > > > > > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | . 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 . This variable holds the value of the \fB\-errorcode\fR return option set by the most recent error that occurred in this interpreter. This list value represents additional information about the error |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 Miguel Sofer <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 Miguel Sofer <[email protected]> * * 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.469 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" #include "tommath.h" #include <math.h> |
︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 602 603 604 | iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be * recorded. */ | > > > > > > > > > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 | iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); 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 * recorded. */ |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * 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.510 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tommath.h" #include <math.h> |
︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 | if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); iPtr->cmdFramePtr = bcFramePtr->nextPtr; | > | > | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 | if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); iPtr->cmdFramePtr = bcFramePtr->nextPtr; 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; } CACHE_STACK_INFO(); if (result == TCL_OK) { |
︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 | * TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; | > | | > | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 | * TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, codePtr, bcFramePtr, pc - codePtr->codeStart); } DECACHE_STACK_INFO(); pc += pcAdjustment; NR_YIELD(1); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 by Miguel Sofer. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 by Miguel Sofer. All rights reserved. * * 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.486 2010/11/15 21:34:54 andreas_kupries Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options. |
︙ | ︙ | |||
2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 | * traces are requested. * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp * has not be initialized. This is set 1 when we first * use the rand() or srand() functions. * 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_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms * of the wrong-num-args string in Tcl_WrongNumArgs. * Makes it append instead of replacing and uses * different intermediate text. | > > > | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 | * traces are requested. * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp * has not be initialized. This is set 1 when we first * use the rand() or srand() functions. * 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. * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms * of the wrong-num-args string in Tcl_WrongNumArgs. * Makes it append instead of replacing and uses * different intermediate text. |
︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 | * WARNING: For the sake of some extensions that have made use of former * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) * or 8 (formerly ERROR_CODE_SET). */ #define DELETED 1 #define ERR_ALREADY_LOGGED 4 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define INTERP_TRACE_IN_PROGRESS 0x200 #define INTERP_ALTERNATE_WRONG_ARGS 0x400 #define ERR_LEGACY_COPY 0x800 #define CANCELED 0x1000 | > | 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 | * WARNING: For the sake of some extensions that have made use of former * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) * or 8 (formerly ERROR_CODE_SET). */ #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 #define INTERP_TRACE_IN_PROGRESS 0x200 #define INTERP_ALTERNATE_WRONG_ARGS 0x400 #define ERR_LEGACY_COPY 0x800 #define CANCELED 0x1000 |
︙ | ︙ |
Changes to generic/tclInterp.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows * * 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.114 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script |
︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 217 218 219 | static void InterpInfoDeleteProc(ClientData clientData, Tcl_Interp *interp); static int SlaveBgerror(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveExpose(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); | > > > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | static void InterpInfoDeleteProc(ClientData clientData, Tcl_Interp *interp); static int SlaveBgerror(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, 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, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); |
︙ | ︙ | |||
557 558 559 560 561 562 563 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", | > | | | > | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "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_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 }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; |
︙ | ︙ | |||
780 781 782 783 784 785 786 787 788 789 790 791 792 793 | Tcl_DecrRefCount(slavePtr); } return TCL_ERROR; } Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } case OPT_DELETE: { int i; InterpInfo *iiPtr; Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); | > > > > > > > > > > > > > > > > > | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | Tcl_DecrRefCount(slavePtr); } return TCL_ERROR; } 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; Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); |
︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { | | | | > | | | > | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 | Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", "eval", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; enum options { 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) { Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { |
︙ | ︙ | |||
2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 | return AliasList(interp, slaveInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); case OPT_EXPOSE: | > > > > > > > > > > | 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 | return AliasList(interp, slaveInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); 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 ...?"); return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); case OPT_EXPOSE: |
︙ | ︙ | |||
2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 | slavePtr->interpCmd = NULL; if (slavePtr->slaveInterp != NULL) { Tcl_DeleteInterp(slavePtr->slaveInterp); } } /* *---------------------------------------------------------------------- * * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 | slavePtr->interpCmd = NULL; if (slavePtr->slaveInterp != NULL) { Tcl_DeleteInterp(slavePtr->slaveInterp); } } /* *---------------------------------------------------------------------- * * 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. |
︙ | ︙ |
Changes to tests/info.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2006 ActiveState # # 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.79 2010/11/15 21:34:54 andreas_kupries Exp $ if {{::tcltest} ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", |
︙ | ︙ | |||
686 687 688 689 690 691 692 | test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s } -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame | < < > > | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s } -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## 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 set cmd [lindex $frame $pos] if {[regexp \n $cmd]} { set first [string range [lindex [split $cmd \n] 0] 0 end-4] set frame [lreplace $frame $pos $pos $first] } set pos [lsearch -exact $frame file] if {$pos >=0} { incr pos set tail [file tail [lindex $frame $pos]] set frame [lreplace $frame $pos $pos $tail] } 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 # implementation of tcltest. Any changes and these tests will have to # be updated. proc etrace {} { |
︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 | etrace } join [lrange [uplevel \#0 $script] 0 2] \n } -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} * {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} | | | | | | | | | | | | | | | | | | | | | | | | | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 | etrace } join [lrange [uplevel \#0 $script] 0 2] \n } -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} * {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} # 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 { set y DPV etrace } join [lrange [control y $script] 0 3] \n } -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {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} # 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 } -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {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}} # 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 { join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n } -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} |
︙ | ︙ | |||
1539 1540 1541 1542 1543 1544 1545 | [set x {}] \ [reduce \ [info frame 0]]";# line 1541 } } -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 { | | | | | | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 | [set x {}] \ [reduce \ [info frame 0]]";# line 1541 } } -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 { subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ [reduce [info frame 0]];# line 1550 } } 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} { subinterp ; set res [interp eval sub { proc abra {script} { uplevel 1 $script } set res [abra { return "\ [reduce [info frame 0]]";# line 1562 }] rename abra {} 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} { proc a {} { proc b {} { if {1} \ { |
︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 | trace remove execution print_one enter get_frame_info rename get_frame_info {} rename test_info_frame {} rename print_one {} } -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1 type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} # ------------------------------------------------------------------------- unset -nocomplain res # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 | trace remove execution print_one enter get_frame_info rename get_frame_info {} rename test_info_frame {} rename print_one {} } -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1 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 catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return |
Changes to tests/interp.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the multiple interpreter facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # This file tests the multiple interpreter facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.69 2010/11/15 21:34:54 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} foreach i [interp slaves] { interp delete $i } # Part 0: Check out options for interp command test interp-1.1 {options for interp command} -returnCodes error -body { interp } -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, 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 } "" test interp-1.4 {options for interp command} -returnCodes error -body { interp delete foo bar } -result {could not find interpreter "foo"} test interp-1.5 {options for interp command} -returnCodes error -body { interp exists foo bar } -result {wrong # args: should be "interp exists ?path?"} # # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { interp slaves foo bar zop } -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, 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, 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, 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"} # Part 1: Basic interpreter creation tests: test interp-2.1 {basic interpreter creation} { interp create a |
︙ | ︙ | |||
3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 | interp create {a b} -safe lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] } -cleanup { unset result interp delete a } -result {26 26} # cleanup foreach i [interp slaves] { interp delete $i } ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 | interp create {a b} -safe lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] } -cleanup { 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] { interp delete $i } ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: |