diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclOO.c | 18 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 71 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 98 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 7 |
4 files changed, 152 insertions, 42 deletions
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 ; i<objc ; i++) { - Object *o2Ptr; + Class *clsPtr = GetClassInOuterContext(interp, objv[i], + "may only mix in classes"); - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]); - if (o2Ptr == NULL) { - goto freeAndError; - } - if (o2Ptr->classPtr == 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 ; i<objc-1 ; i++) { - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]); - if (o2Ptr == NULL) { - goto failedAfterAlloc; - } - if (o2Ptr->classPtr == 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 ; j<i ; j++) { - if (superclasses[j] == o2Ptr->classPtr) { + 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. |