summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c18
-rw-r--r--generic/tclOOBasic.c71
-rw-r--r--generic/tclOODefineCmds.c98
-rw-r--r--generic/tclOOInt.h7
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.