diff options
author | dkf <dkf@noemail.net> | 2008-10-31 22:08:31 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2008-10-31 22:08:31 (GMT) |
commit | 3c93321249970564737718ffc5993c5d8ce46020 (patch) | |
tree | 48e83fa4c090195326480154283f0888f703a276 /generic/tclOOBasic.c | |
parent | 7a7edf82d3d4faf5b2c056a7c5e5865a97d8bdd8 (diff) | |
download | tcl-3c93321249970564737718ffc5993c5d8ce46020.zip tcl-3c93321249970564737718ffc5993c5d8ce46020.tar.gz tcl-3c93321249970564737718ffc5993c5d8ce46020.tar.bz2 |
Fix [Bug 2200824] and make class constructor error handling much more robust.
FossilOrigin-Name: c8dd022f7e09fd76778993ccb2afd93d8089305a
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r-- | generic/tclOOBasic.c | 71 |
1 files changed, 70 insertions, 1 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index cbece15..394ea60 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOBasic.c,v 1.13 2008/10/16 22:34:18 nijtmans Exp $ + * RCS: @(#) $Id: tclOOBasic.c,v 1.14 2008/10/31 22:08:32 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -975,6 +975,75 @@ TclOOCopyObjectCmd( } /* + * ---------------------------------------------------------------------- + * + * TclOOUpcatchCmd -- + * + * Implementation of the [oo::UpCatch] command, which is a combination of + * [uplevel 1] and [catch] that makes it easier to write transparent + * error handling in scripts. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOUpcatchCmd( + ClientData ignored, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv); +} + +static int +UpcatchCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *savedFramePtr = data[0]; + Tcl_Obj *resultObj[2]; + int rewind = iPtr->execEnvPtr->rewind; + + iPtr->varFramePtr = savedFramePtr; + if (rewind || Tcl_LimitExceeded(interp)) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"UpCatch\" body line %d)", interp->errorLine)); + return TCL_ERROR; + } + resultObj[0] = Tcl_GetObjResult(interp); + resultObj[1] = Tcl_GetReturnOptions(interp, result); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj)); + return TCL_OK; +} + +int +TclOONRUpcatch( + ClientData ignored, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *savedFramePtr = iPtr->varFramePtr; + Tcl_Obj *scriptObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "script"); + return TCL_ERROR; + } + if (iPtr->varFramePtr->callerVarPtr != NULL) { + iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; + } + + Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL); + return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR, + iPtr->cmdFramePtr, 1); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |