summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog46
-rw-r--r--generic/tclOO.c18
-rw-r--r--generic/tclOOBasic.c71
-rw-r--r--generic/tclOODefineCmds.c98
-rw-r--r--generic/tclOOInt.h7
-rw-r--r--tests/oo.test51
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 <dkf@users.sf.net>
+
+ * 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 <nijtmans@users.sf.net>
* generic/tclCompile.h: CONSTify TclDTraceInfo
@@ -8,27 +25,26 @@
2008-10-27 Don Porter <dgp@users.sourceforge.net>
- * 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 <patthoyts@users.sourceforge.net>
* 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 <msofer@users.sf.net>
- * 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 <nijtmans@users.sf.net>
@@ -53,7 +69,7 @@
2008-10-19 Don Porter <dgp@users.sourceforge.net>
* 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 <dkf@users.sf.net>
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.
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 {
generated by cgit v0.12 at 2024-11-01 15:02:10 (GMT)