From ea04b9849eb076f206c65efacd0a6a3aba6f4325 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 31 Oct 2008 22:08:32 +0000 Subject: Fix [Bug 2200824] and make class constructor error handling much more robust. --- ChangeLog | 46 ++++++++++++++-------- generic/tclOO.c | 18 ++++++--- generic/tclOOBasic.c | 71 +++++++++++++++++++++++++++++++++- generic/tclOODefineCmds.c | 98 +++++++++++++++++++++++++++++++---------------- generic/tclOOInt.h | 7 +++- tests/oo.test | 51 +++++++++++++++++++++++- 6 files changed, 233 insertions(+), 58 deletions(-) diff --git a/ChangeLog b/ChangeLog index e2d4608..6880855 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2008-10-31 Donal K. Fellows + + * generic/tclOOBasic.c (TclOONRUpcatch): Reworked the code that does + * generic/tclOO.c (InitFoundation): class constructor handling so + that it is more robust and runs the constructor call in the context of + the caller of the class's constructor method. Needed because the + previously used code did not work at all after applying the fix below; + no Tcl existing command could reliably do what was needed any more. + + * generic/tclOODefineCmds.c (GetClassInOuterContext): Rework and + factor out the code to resolve class names in definitions so that + classes are resolved from the perspective of the caller of the + [oo::define] command, rather than from the oo::define namespace! This + makes much code simpler by reducing how often fully-qualified names + are required (previously always in practice, so no back-compat issues + exist). [Bug 2200824] + 2008-10-28 Jan Nijtmans * generic/tclCompile.h: CONSTify TclDTraceInfo @@ -8,27 +25,26 @@ 2008-10-27 Don Porter - * generic/tclEncoding.c: Use "iso8859-1" and not "identity" - as the default and original [encoding system] value. Since - "iso8859-1" is built in to the C source code for Tcl now, there's no - availability issue, and it has the good feature of "identity" that - we must have ("bytes in" == "bytes out") without the bad feature of - "identity" ("broken as designed") that makes us want to abandon it. - [RFE 2008609] - *** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and - any other code expecting a particular value for Tcl's default - system encoding *** + * generic/tclEncoding.c: Use "iso8859-1" and not "identity" as + the default and original [encoding system] value. Since "iso8859-1" is + built in to the C source code for Tcl now, there's no availability + issue, and it has the good feature of "identity" that we must have + ("bytes in" == "bytes out") without the bad feature of "identity" + ("broken as designed") that makes us want to abandon it. [RFE 2008609] + *** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and any + other code expecting a particular value for Tcl's default system + encoding *** 2008-10-24 Pat Thoyts * library/http/http.tcl: Fixed a failure to read SHOUTcast streams - with the new 2.7 package. Introduced a new intial state as the - first response may not be HTTP*. + with the new 2.7 package. Introduced a new intial state as the first + response may not be HTTP*. 2008-10-23 Miguel Sofer - * generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in - the for body [Bug 2186888]. + * generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in the for + body [Bug 2186888]. 2008-10-22 Jan Nijtmans @@ -53,7 +69,7 @@ 2008-10-19 Don Porter * generic/tclProc.c: Reset -level and -code values to defaults - after they are used. [Bug 2152286]. + after they are used. [Bug 2152286] 2008-10-19 Donal K. Fellows diff --git a/generic/tclOO.c b/generic/tclOO.c index 11a7cbd..e161563 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.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: tclOO.c,v 1.17 2008/09/23 05:05:48 dkf Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.18 2008/10/31 22:08:32 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -246,6 +246,8 @@ InitFoundation( Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); + Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, + TclOONRUpcatch, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", TclOOUnknownDefinition, NULL, NULL); namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1); @@ -309,6 +311,10 @@ InitFoundation( * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. + * + * The 0xDeadBeef is a special signal to the errorInfo logger that is used + * by constructors that stops it from generating extra error information + * that is confusing. */ namePtr = Tcl_NewStringObj("new", -1); @@ -318,12 +324,12 @@ InitFoundation( argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1); Tcl_IncrRefCount(argsPtr); bodyPtr = Tcl_NewStringObj( - "if {[catch {define [self] $definitionScript} msg opt]} {\n" - "set ei [split [dict get $opt -errorinfo] \\n]\n" - "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n" - "dict set opt -errorline 0xdeadbeef\n" + "set script [list ::oo::define [self] $definitionScript];" + "lassign [::oo::UpCatch $script] msg opts\n" + "if {[dict get $opts -code] == 1} {" + " dict set opts -errorline 0xDeadBeef\n" "}\n" - "return -options $opt $msg", -1); + "return -options $opts $msg", -1); fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); Tcl_DecrRefCount(argsPtr); 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 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 4d680ea..a96d267 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.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: tclOODefineCmds.c,v 1.6 2008/10/10 13:04:09 dkf Exp $ + * RCS: @(#) $Id: tclOODefineCmds.c,v 1.7 2008/10/31 22:08:32 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -25,6 +25,8 @@ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); +static inline Class * GetClassInOuterContext(Tcl_Interp *interp, + Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); @@ -605,6 +607,46 @@ TclOOGetDefineCmdContext( /* * ---------------------------------------------------------------------- * + * GetClassInOuterContext -- + * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the + * context that called oo::define (or equivalent). Note that this may + * have to go up multiple levels to get the level that we started doing + * definitions at. + * + * ---------------------------------------------------------------------- + */ + +static inline Class * +GetClassInOuterContext( + Tcl_Interp *interp, + Tcl_Obj *className, + const char *errMsg) +{ + Interp *iPtr = (Interp *) interp; + Object *oPtr; + CallFrame *savedFramePtr = iPtr->varFramePtr; + + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { + if (iPtr->varFramePtr->callerVarPtr == NULL) { + Tcl_Panic("getting outer context when already in global context"); + } + iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, className); + iPtr->varFramePtr = savedFramePtr; + if (oPtr == NULL) { + return NULL; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, errMsg, NULL); + return NULL; + } + return oPtr->classPtr; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the @@ -982,7 +1024,8 @@ TclOODefineClassObjCmd( int objc, Tcl_Obj *const *objv) { - Object *oPtr, *o2Ptr; + Object *oPtr; + Class *clsPtr; Foundation *fPtr = TclOOGetFoundation(interp); /* @@ -1012,13 +1055,9 @@ TclOODefineClassObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "the class of an object must be a class", - NULL); + clsPtr = GetClassInOuterContext(interp, objv[1], + "the class of an object must be a class"); + if (clsPtr == NULL) { return TCL_ERROR; } @@ -1028,8 +1067,7 @@ TclOODefineClassObjCmd( * produce an error if any attempt is made to swap from one to the other. */ - if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls, - o2Ptr->classPtr)) { + if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { Tcl_AppendResult(interp, "may not change a ", (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); @@ -1040,9 +1078,9 @@ TclOODefineClassObjCmd( * Set the object's class. */ - if (oPtr->selfCls != o2Ptr->classPtr) { + if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); - oPtr->selfCls = o2Ptr->classPtr; + oPtr->selfCls = clsPtr; TclOOAddToInstances(oPtr, oPtr->selfCls); if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); @@ -1513,23 +1551,17 @@ TclOODefineMixinObjCmd( mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); for (i=1 ; iclassPtr == NULL) { - Tcl_AppendResult(interp, "may only mix in classes; \"", - TclGetString(objv[i]), "\" is not a class", NULL); + if (clsPtr == NULL) { goto freeAndError; } - if (!isInstanceMixin && - TclOOIsReachable(oPtr->classPtr,o2Ptr->classPtr)){ + if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { Tcl_AppendResult(interp, "may not mix a class into itself", NULL); goto freeAndError; } - mixins[i-1] = o2Ptr->classPtr; + mixins[i-1] = clsPtr; } if (isInstanceMixin) { @@ -1617,7 +1649,7 @@ TclOODefineSuperclassObjCmd( int objc, Tcl_Obj *const *objv) { - Object *oPtr, *o2Ptr; + Object *oPtr; Foundation *fPtr = TclOOGetFoundation(interp); Class **superclasses, *superPtr; int i, j; @@ -1657,29 +1689,27 @@ TclOODefineSuperclassObjCmd( */ for (i=0 ; iclassPtr == NULL) { - Tcl_AppendResult(interp, "only a class can be a superclass",NULL); + Class *clsPtr = GetClassInOuterContext(interp, objv[i+1], + "only a class can be a superclass"); + + if (clsPtr == NULL) { goto failedAfterAlloc; } for (j=0 ; jclassPtr) { + if (superclasses[j] == clsPtr) { Tcl_AppendResult(interp, "class should only be a direct superclass once",NULL); goto failedAfterAlloc; } } - if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) { + if (TclOOIsReachable(oPtr->classPtr, clsPtr)) { Tcl_AppendResult(interp, "attempt to form circular dependency graph", NULL); failedAfterAlloc: ckfree((char *) superclasses); return TCL_ERROR; } - superclasses[i] = o2Ptr->classPtr; + superclasses[i] = clsPtr; } /* diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 4b6b8a0..3221fcc 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -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: tclOOInt.h,v 1.9 2008/10/13 13:13:45 dkf Exp $ + * RCS: @(#) $Id: tclOOInt.h,v 1.10 2008/10/31 22:08:32 dkf Exp $ */ #ifndef TCL_OO_INTERNAL_H @@ -525,6 +525,8 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_Obj *const *objv, int skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); +MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, @@ -534,6 +536,9 @@ MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); +MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); /* * Include all the private API, generated from tclOO.decls. diff --git a/tests/oo.test b/tests/oo.test index 2df1d4d..ff2f79f 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.15 2008/10/10 13:04:09 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.16 2008/10/31 22:08:32 dkf Exp $ package require TclOO 0.4 ;# Must match value in configure.in if {[lsearch [namespace children] ::tcltest] == -1} { @@ -594,6 +594,25 @@ test oo-7.8 {OO: next at the end of the method chain} -setup { } lappend result [catch {[foo2 new] bar} msg] $msg } -result {foo2 foo 1 {no next method implementation}} +test oo-7.9 {OO: defining inheritance in namespaces} -setup { + set ::result {} + oo::class create ::master + namespace eval ::foo { + oo::class create mixin {superclass ::master} + } +} -cleanup { + ::master destroy + namespace delete ::foo +} -body { + namespace eval ::foo { + oo::class create bar {superclass master} + oo::class create boo + oo::define boo {superclass bar} + oo::define boo {mixin mixin} + oo::class create spong {superclass boo} + return + } +} -result {} test oo-8.1 {OO: global must work in methods} { oo::object create foo @@ -1324,6 +1343,36 @@ test oo-18.3 {OO: define command support} { (in definition script for object "::foo" line 1) invoked from within "oo::class create foo {error bar}"}} +test oo-18.3a {OO: define command support} { + list [catch {oo::class create foo { + error bar +}} msg] $msg $errorInfo +} {1 bar {bar + while executing +"error bar" + (in definition script for object "::foo" line 2) + invoked from within +"oo::class create foo { + error bar +}"}} +test oo-18.3b {OO: define command support} { + list [catch {oo::class create foo { + eval eval error bar +}} msg] $msg $errorInfo +} {1 bar {bar + while executing +"error bar" + ("eval" body line 1) + invoked from within +"eval error bar" + ("eval" body line 1) + invoked from within +"eval eval error bar" + (in definition script for object "::foo" line 2) + invoked from within +"oo::class create foo { + eval eval error bar +}"}} test oo-18.4 {OO: more error traces from the guts} -setup { oo::object create obj } -body { -- cgit v0.12