From 3ffda83a5b3d9b03fa4bad1e5384919a46adf47a Mon Sep 17 00:00:00 2001 From: ferrieux Date: Mon, 16 Nov 2009 17:38:08 +0000 Subject: (forward port) Fix [Bug 2891556] and improve test to detect similar manifestations in the future. Add tcltest support for finalization. --- ChangeLog | 6 ++++++ doc/catch.n | 45 +++++++++++++++++++++++++--------------- doc/info.n | 12 ++++++++++- generic/tclBasic.c | 8 +++++++- generic/tclCmdIL.c | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclEncoding.c | 28 +++++++++++++++++++------ generic/tclInt.h | 4 +++- generic/tclNamesp.c | 36 ++++++++++++++++++++++++++++++-- generic/tclResult.c | 9 ++++++-- generic/tclTest.c | 47 +++++++++++++++++++++++++++++++++++++++++- tests/cmdMZ.test | 28 ++++++++++++------------- tests/encoding.test | 5 +++-- tests/error.test | 24 +++++++++++++++++++++- tests/execute.test | 6 +++--- tests/info.test | 10 ++++----- tests/init.test | 4 ++-- 16 files changed, 270 insertions(+), 59 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2f54ae6..0dcbf3f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2009-11-16 Alexandre Ferrieux + + * generic/tclEncoding.c: (forward port) Fix [Bug 2891556] and improve + * generic/tclTest.c: test to detect similar manifestations in the + * tests/encoding.test: future. Add tcltest support for finalization. + 2009-11-15 Mo DeJong * win/tclWinDde.c: Avoid gcc compiler warning by diff --git a/doc/catch.n b/doc/catch.n index bf302ba..f06220b 100644 --- a/doc/catch.n +++ b/doc/catch.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: catch.n,v 1.20 2008/10/17 10:22:25 dkf Exp $ +'\" RCS: @(#) $Id: catch.n,v 1.21 2009/11/16 17:38:08 ferrieux Exp $ '\" .so man.macros .TH catch n "8.5" Tcl "Tcl Built-In Commands" @@ -54,22 +54,33 @@ Only when the return code is \fBTCL_RETURN\fR will the values of the \fB\-level\fR and \fB\-code\fR entries be something else, as further described in the documentation for the \fBreturn\fR command. .PP -When the return code from evaluation of \fIscript\fR is \fBTCL_ERROR\fR, -three additional entries are defined in the dictionary of return options -stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR, \fB\-errorcode\fR, -and \fB\-errorline\fR. The value of the \fB\-errorinfo\fR entry -is a formatted stack trace containing more information about -the context in which the error happened. The formatted stack -trace is meant to be read by a person. The value of -the \fB\-errorcode\fR entry is additional information about the -error stored as a list. The \fB\-errorcode\fR value is meant to -be further processed by programs, and may not be particularly -readable by people. The value of the \fB\-errorline\fR entry -is an integer indicating which line of \fIscript\fR was being -evaluated when the error occurred. The values of the \fB\-errorinfo\fR -and \fB\-errorcode\fR entries of the most recent error are also -available as values of the global variables \fB::errorInfo\fR -and \fB::errorCode\fR respectively. +When the return code from evaluation of \fIscript\fR is +\fBTCL_ERROR\fR, four additional entries are defined in the dictionary +of return options stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR, +\fB\-errorcode\fR, \fB\-errorline\fR, and \fB\-errorstack\fR. The +value of the \fB\-errorinfo\fR entry is a formatted stack trace +containing more information about the context in which the error +happened. The formatted stack trace is meant to be read by a person. +The value of the \fB\-errorcode\fR entry is additional information +about the error stored as a list. The \fB\-errorcode\fR value is +meant to be further processed by programs, and may not be particularly +readable by people. The value of the \fB\-errorline\fR entry is an +integer indicating which line of \fIscript\fR was being evaluated when +the error occurred. The value of the \fB\-errorstack\fR entry is a +list of lists made of the function names and arguments at each level +from the call stack when the error occurred. It differs from +-errorinfo in that (1) it is a true list of lists, for easy +programmatic access without parsing, (2) it contains the true +(substituted) values passed to the functions, instead of the static +text of the calling sites, and (3) it is coarser-grained, with only +one element per stack frame (like procs; no separate elements for +[foreach] constructs for example). + +The values of the \fB\-errorinfo\fR and \fB\-errorcode\fR entries of +the most recent error are also available as values of the global +variables \fB::errorInfo\fR and \fB::errorCode\fR respectively. The +value of the \fB\-errorstack\fR entry surfaces as \fBinfo +errorstack\fR. .PP Tcl packages may provide commands that set other entries in the dictionary of return options, and the \fBreturn\fR command may be diff --git a/doc/info.n b/doc/info.n index b4c4b60..9fd0fde 100644 --- a/doc/info.n +++ b/doc/info.n @@ -8,7 +8,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.n,v 1.33 2009/05/15 10:08:02 dkf Exp $ +'\" RCS: @(#) $Id: info.n,v 1.34 2009/11/16 17:38:08 ferrieux Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -94,6 +94,16 @@ does not have a default value then the command returns \fB0\fR. Otherwise it returns \fB1\fR and places the default value of \fIarg\fR into variable \fIvarname\fR. .TP +\fBinfo errorstack \fR?\fIinterp\fR? +. +Returns a list of lists made of the function names and arguments at +each level from the call stack of the last error in the given +\fIinterp\fR, or in the current one if not specified. This +information is also present in the -errorstack entry of the options +dictionary returned by 3-arg \fBcatch\fR; \fBinfo errorstack\fR is a +convenient way of retrieving it for uncaught errors at toplevel in an +interactive tclsh. +.TP \fBinfo exists \fIvarName\fR . Returns \fB1\fR if the variable named \fIvarName\fR exists in the diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cca8fba..c8ae5ae 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.407 2009/11/10 20:53:24 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.408 2009/11/16 17:38:08 ferrieux Exp $ */ #include "tclInt.h" @@ -530,6 +530,9 @@ Tcl_CreateInterp(void) iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); + iPtr->errorStack = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(iPtr->errorStack); + iPtr->resetErrorStack = 1; iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); @@ -1470,6 +1473,7 @@ DeleteInterpProc( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } + Tcl_DecrRefCount(iPtr->errorStack); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } @@ -8820,5 +8824,7 @@ TclInfoCoroutineCmd( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 03f5593..9c89ae4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.171 2009/08/20 10:56:55 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.172 2009/11/16 17:38:08 ferrieux Exp $ */ #include "tclInt.h" @@ -118,6 +118,9 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +/* TIP #348 - New 'info' subcommand 'errorstack' */ +static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); /* TIP #280 - New 'info' subcommand 'frame' */ static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -164,6 +167,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"complete", InfoCompleteCmd, NULL}, {"coroutine", TclInfoCoroutineCmd, NULL}, {"default", InfoDefaultCmd, NULL}, + {"errorstack", InfoErrorStackCmd, NULL}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd}, {"frame", InfoFrameCmd, NULL}, {"functions", InfoFunctionsCmd, NULL}, @@ -1017,6 +1021,55 @@ InfoDefaultCmd( /* *---------------------------------------------------------------------- * + * InfoErrorStackCmd -- + * + * Called to implement the "info errorstack" command that returns information + * about the last error's call stack. Handles the following syntax: + * + * info errorstack ?interp? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoErrorStackCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Interp *target; + Interp *iPtr; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + return TCL_ERROR; + } + + target = interp; + if (objc == 2) { + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } + } + + iPtr = (Interp *) target; + Tcl_SetObjResult(interp, iPtr->errorStack); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclInfoExistsCmd -- * * Called to implement the "info exists" command that determines whether @@ -4388,5 +4441,7 @@ SelectObjFromSublist( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 441e099..2188256 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.66 2009/02/10 22:49:55 nijtmans Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.67 2009/11/16 17:38:08 ferrieux Exp $ */ #include "tclInt.h" @@ -844,6 +844,9 @@ FreeEncoding( if (encodingPtr == NULL) { return; } + if (encodingPtr->refCount<=0) { + Tcl_Panic("FreeEncoding: refcount problem !!!"); + } encodingPtr->refCount--; if (encodingPtr->refCount == 0) { if (encodingPtr->freeProc != NULL) { @@ -3385,11 +3388,24 @@ EscapeFreeProc( if (dataPtr == NULL) { return; } - subTablePtr = dataPtr->subTables; - for (i = 0; i < dataPtr->numSubTables; i++) { - FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); - subTablePtr++; - } + /* + * The subTables should be freed recursively in normal operation but not + * during TclFinalizeEncodingSubsystem because they are also present as a + * weak reference in the toplevel encodingTable (ie they don't have a +1 + * refcount for this), and unpredictable nuking order could remove them + * from under the following loop's feet [Bug 2891556]. + * + * The encodingsInitialized flag, being reset on entry to TFES, can serve + * as a "not in finalization" test. + */ + if (encodingsInitialized) + { + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + subTablePtr++; + } + } ckfree((char *) dataPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 0f6654b..be536a9 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.445 2009/09/30 03:11:26 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.446 2009/11/16 17:38:08 ferrieux Exp $ */ #ifndef _TCLINT @@ -1895,6 +1895,8 @@ typedef struct Interp { Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */ Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */ Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable. */ + Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */ + int resetErrorStack; /* controls cleaning up of ::errorStack */ int returnLevel; /* [return -level] parameter. */ /* diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 94ade8f..2b9b508 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.193 2009/09/30 03:11:26 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.194 2009/11/16 17:38:09 ferrieux Exp $ */ #include "tclInt.h" @@ -7574,7 +7574,7 @@ Tcl_LogCommandInfo( { register const char *p; Interp *iPtr = (Interp *) interp; - int overflow, limit = 150; + int overflow, limit = 150, len; Var *varPtr, *arrayPtr; if (iPtr->flags & ERR_ALREADY_LOGGED) { @@ -7633,6 +7633,36 @@ Tcl_LogCommandInfo( TCL_GLOBAL_ONLY); } } + + /* + * TIP #348 + */ + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + if (iPtr->resetErrorStack) { + iPtr->resetErrorStack = 0; + /* reset while keeping the list intrep as much as possible */ + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + len=0; + } + if (iPtr->varFramePtr != iPtr->rootFramePtr) { + Tcl_Obj *listPtr; + int result; + listPtr=Tcl_NewListObj(iPtr->varFramePtr->objc, + iPtr->varFramePtr->objv); + result = Tcl_ListObjReplace(interp, iPtr->errorStack, len, 0, 1, &listPtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); + } + } } /* @@ -7640,5 +7670,7 @@ Tcl_LogCommandInfo( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclResult.c b/generic/tclResult.c index 921a867..3d6284e 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.54 2008/12/17 16:47:38 nijtmans Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.55 2009/11/16 17:38:09 ferrieux Exp $ */ #include "tclInt.h" @@ -19,7 +19,7 @@ enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, - KEY_LEVEL, KEY_OPTIONS, KEY_LAST + KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST }; /* @@ -922,6 +922,7 @@ Tcl_ResetResult( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } + iPtr->resetErrorStack = 1; iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; if (iPtr->returnOpts) { @@ -1158,6 +1159,7 @@ GetKeys(void) TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode"); TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo"); TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline"); + TclNewLiteralStringObj(keys[KEY_ERRORSTACK],"-errorstack"); TclNewLiteralStringObj(keys[KEY_LEVEL], "-level"); TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options"); @@ -1503,6 +1505,7 @@ Tcl_GetReturnOptions( Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], Tcl_NewIntObj(iPtr->errorLine)); } + Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); return options; } @@ -1624,5 +1627,7 @@ Tcl_TransferResult( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclTest.c b/generic/tclTest.c index da00e84..cdaa440 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.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: tclTest.c,v 1.136 2009/02/10 23:09:08 nijtmans Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.137 2009/11/16 17:38:09 ferrieux Exp $ */ #define TCL_TEST @@ -290,6 +290,9 @@ static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestfinexitObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -619,6 +622,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, NULL); + Tcl_CreateCommand(interp, "testfinexit", TestfinexitObjCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -4358,6 +4362,47 @@ TestpanicCmd( return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestfinexitObjCmd -- + * + * Calls a variant of [exit] including the full finalization path. + * + * Results: + * Error, or doesn't return. + * + * Side effects: + * Exits application. + * + *---------------------------------------------------------------------- + */ + +static int +TestfinexitObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int value; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); + return TCL_ERROR; + } + + if (objc == 1) { + value = 0; + } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_Finalize(); + TclpExit(value); + /*NOTREACHED*/ + return TCL_ERROR; /* Better not ever reach this! */ +} static int TestfileCmd( diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index ae96301..8ae7a3a 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdMZ.test,v 1.26 2008/09/10 13:50:05 dkf Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.27 2009/11/16 17:38:09 ferrieux Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -119,18 +119,18 @@ proc dictSort {d} { return $result } -test cmdMZ-return-2.0 {return option handling} { +test cmdMZ-return-2.0 {return option handling} -body { list [catch return -> foo] [dictSort $foo] -} {2 {-code 0 -level 1}} -test cmdMZ-return-2.1 {return option handling} { +} -match glob -result {2 {-code 0 -errorstack * -level 1}} +test cmdMZ-return-2.1 {return option handling} -body { list [catch {return -bar soom} -> foo] [dictSort $foo] -} {2 {-bar soom -code 0 -level 1}} -test cmdMZ-return-2.2 {return option handling} { +} -match glob -result {2 {-bar soom -code 0 -errorstack * -level 1}} +test cmdMZ-return-2.2 {return option handling} -body { list [catch {return -code return} -> foo] [dictSort $foo] -} {2 {-code 0 -level 2}} -test cmdMZ-return-2.3 {return option handling} { +} -match glob -result {2 {-code 0 -errorstack * -level 2}} +test cmdMZ-return-2.3 {return option handling} -body { list [catch {return -code return -level 10} -> foo] [dictSort $foo] -} {2 {-code 0 -level 11}} +} -match glob -result {2 {-code 0 -errorstack * -level 11}} test cmdMZ-return-2.4 {return option handling} -body { return -level 0 -code error } -returnCodes error -result {} @@ -149,14 +149,14 @@ test cmdMZ-return-2.8 {return option handling} -body { test cmdMZ-return-2.9 {return option handling} -body { return -level 0 -code 10 } -returnCodes 10 -result {} -test cmdMZ-return-2.10 {return option handling} { +test cmdMZ-return-2.10 {return option handling} -body { list [catch {return -level 0 -code error} -> foo] [dictSort $foo] -} {1 {-code 1 -errorcode NONE -errorinfo { +} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo { while executing -"return -level 0 -code error"} -errorline 1 -level 0}} -test cmdMZ-return-2.11 {return option handling} { +"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}} +test cmdMZ-return-2.11 {return option handling} -body { list [catch {return -level 0 -code break} -> foo] [dictSort $foo] -} {3 {-code 3 -level 0}} +} -match glob -result {3 {-code 3 -errorstack * -level 0}} test cmdMZ-return-2.12 {return option handling} -body { return -level 0 -code error -options {-code ok} } -returnCodes ok -result {} diff --git a/tests/encoding.test b/tests/encoding.test index 0aa49d3..bc57b2d 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: encoding.test,v 1.28 2008/06/20 16:18:13 dgp Exp $ +# RCS: @(#) $Id: encoding.test,v 1.29 2009/11/16 17:38:09 ferrieux Exp $ package require tcltest 2 @@ -414,9 +414,10 @@ test encoding-24.2 {EscapeFreeProc on open channels} -constraints { } -setup { # Bug #524674 output set file [makeFile { + encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g - exit + testfinexit } iso2022.tcl] } -body { viewable [exec [interpreter] $file] diff --git a/tests/error.test b/tests/error.test index e18afad..1b0f0fa 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: error.test,v 1.22 2009/09/28 18:02:20 dgp Exp $ +# RCS: @(#) $Id: error.test,v 1.23 2009/11/16 17:38:09 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -153,6 +153,19 @@ test error-4.5 {errorInfo and errorCode variables} { list [catch {error msg1 msg2 {}} msg] $msg $::errorInfo $::errorCode } {1 msg1 msg2 {}} +test error-4.6 {errorstack via info } -body { + proc f x {g $x$x} + proc g x {error G:$x} + catch {f 12} + info errorstack +} -match glob -result {{g 1212} {f 12} {namespace eval *}} +test error-4.7 {errorstack via options dict } -body { + proc f x {g $x$x} + proc g x {error G:$x} + catch {f 12} m d + dict get $d -errorstack +} -match glob -result {{g 1212} {f 12} {namespace eval *}} + # Errors in error command itself test error-5.1 {errors in error command} { @@ -207,6 +220,15 @@ test error-6.9 {catch must reset error state} { catch foo list $::errorCode } {NONE} +test error-6.10 {catch must reset errorstack} -body { + proc f x {g $x$x} + proc g x {error G:$x} + catch {f 12} + set e1 [info errorstack] + catch {f 13} + set e2 [info errorstack] + list $e1 $e2 +} -match glob -result {{{g 1212} {f 12} {namespace eval *}} {{g 1313} {f 13} {namespace eval *}}} test error-7.1 {Bug 1397843} -body { variable cmds diff --git a/tests/execute.test b/tests/execute.test index b277da8..aa9e943 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -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: execute.test,v 1.32 2009/06/24 13:51:36 dgp Exp $ +# RCS: @(#) $Id: execute.test,v 1.33 2009/11/16 17:38:09 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -956,11 +956,11 @@ test execute-8.5 {Bug 2038069} -setup { demo } -cleanup { rename demo {} -} -result {-code 1 -level 0 -errorcode NONE -errorinfo {FOO +} -match glob -result {-code 1 -level 0 -errorcode NONE -errorinfo {FOO while executing "error FOO" invoked from within -"catch [list error FOO] m o"} -errorline 2} +"catch \[list error FOO\] m o"} -errorline 2 -errorstack *} test execute-9.1 {Interp result resetting [Bug 1522803]} { set c 0 diff --git a/tests/info.test b/tests/info.test index 21b7712..aa4a29f 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.71 2009/11/10 17:57:39 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.72 2009/11/16 17:38:09 ferrieux Exp $ if {{::tcltest} ni [namespace children]} { package require tcltest 2 @@ -676,16 +676,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": 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} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": 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} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": 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} 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, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -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} ## # ### ### ### ######### ######### ######### diff --git a/tests/init.test b/tests/init.test index 41b8382..b5eba4c 100644 --- a/tests/init.test +++ b/tests/init.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: init.test,v 1.19 2009/07/25 22:00:10 dkf Exp $ +# RCS: @(#) $Id: init.test,v 1.20 2009/11/16 17:38:09 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -181,7 +181,7 @@ test init-5.0 {return options passed through ::unknown} -setup { list $code $foo $bar $code2 $foo2 $bar2 } -cleanup { unset ::auto_index(::xxx) -} -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}} +} -match glob -result {2 xxx {-errorcode NONE -errorstack * -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE -errorstack *}} cleanupTests } ;# End of [interp eval $testInterp] -- cgit v0.12