diff options
| author | ferrieux <ferrieux@users.sourceforge.net> | 2009-11-16 17:38:08 (GMT) |
|---|---|---|
| committer | ferrieux <ferrieux@users.sourceforge.net> | 2009-11-16 17:38:08 (GMT) |
| commit | 3ffda83a5b3d9b03fa4bad1e5384919a46adf47a (patch) | |
| tree | 1b93d42b56b88ab1862f7389658528282be889d6 /generic/tclTest.c | |
| parent | d264119bd45f0b0e694574efc0a627ac1a4232cb (diff) | |
| download | tcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.zip tcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.tar.gz tcl-3ffda83a5b3d9b03fa4bad1e5384919a46adf47a.tar.bz2 | |
(forward port) Fix [Bug 2891556] and improve test to detect similar manifestations in the future. Add tcltest support for finalization.
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 47 |
1 files changed, 46 insertions, 1 deletions
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( |