Clarify the rules for resolution of what forwarded methods forward to.

5 files changed, 146 insertions, 22 deletions

diff --git a/ChangeLog b/ChangeLog
index 36ac90a..0b4bf6f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2009-04-11  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOMethod.c (InvokeForwardMethod): Clarify the resolution
+	behaviour of the name of the command that is forwarded to: it's now
+	resolved using the object's namespace as context, which is much more
+	useful than the previous (somewhat random) behaviour of using the
+	caller's current namespace.
+
 2009-04-10  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
 	* library/http/http.tcl:     Improved HTTP/1.1 support and added
diff --git a/doc/define.n b/doc/define.n
index ddbf476..e3f2e39 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -4,7 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
-'\" RCS: @(#) $Id: define.n,v 1.2 2008/09/23 05:05:47 dkf Exp $
+'\" RCS: @(#) $Id: define.n,v 1.3 2009/04/11 11:18:51 dkf Exp $
 '\"
 .so man.macros
 .TH define n 0.3 TclOO "TclOO Commands"
@@ -94,23 +94,27 @@ arguments are present, the list of filter names is set to empty.
 .TP
 \fBforward\fI name cmdName \fR?\fIarg ...\fR?
 .
-This creates or updates a forwarded method called \fIname\fR. The method
-is defined be forwarded to the command called \fIcmdName\fR, with additional
+This creates or updates a forwarded method called \fIname\fR. The method is
+defined be forwarded to the command called \fIcmdName\fR, with additional
 arguments, \fIarg\fR etc., added before those arguments specified by the
-caller of the method. Forwarded methods should be deleted using the
-\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
-a lower-case letter, and non-exported otherwise.
+caller of the method. The \fIcmdName\fR will always be resolved using the
+rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not
+fully-qualified, the command will be searched for in each object's namespace,
+using the instances' namespace's path, or by looking in the global namespace.
+The method will be exported if \fIname\fR starts with a lower-case letter, and
+non-exported otherwise.
 .TP
 \fBmethod\fI name argList bodyScript\fR
 .
-This creates, updates or deletes a method. The name of the method is
-\fIname\fR, the formal arguments to the method (defined using the same format
-as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
-method will be \fIbodyScript\fR. When the body of the method is evaluated, the
-current namespace of the method will be a namespace that is unique to the
-current object. The method will be exported if \fIname\fR starts with a
-lower-case letter, and non-exported otherwise; this behavior can be overridden
-via \fBexport\fR and \fBunexport\fR.
+This creates or updates a method that is implemented as a procedure-like
+script. The name of the method is \fIname\fR, the formal arguments to the
+method (defined using the same format as for the Tcl \fBproc\fR command) will
+be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When
+the body of the method is evaluated, the current namespace of the method will
+be a namespace that is unique to the current object. The method will be
+exported if \fIname\fR starts with a lower-case letter, and non-exported
+otherwise; this behavior can be overridden via \fBexport\fR and
+\fBunexport\fR.
 .TP
 \fBmixin\fR ?\fIclassName ...\fR?
 .
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 3221fcc..1579ddb 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.10 2008/10/31 22:08:32 dkf Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.11 2009/04/11 11:18:51 dkf Exp $
  */
 
 #ifndef TCL_OO_INTERNAL_H
@@ -117,13 +117,19 @@ typedef struct ProcedureMethod {
 #define USE_DECLARER_NS		0x80
 
 /*
- * Forwarded methods have the following extra information. It is a
- * single-field structure because this allows for future expansion without
- * changing vast amounts of code.
+ * Forwarded methods have the following extra information.
  */
 
 typedef struct ForwardMethod {
-    Tcl_Obj *prefixObj;
+    Tcl_Obj *prefixObj;		/* The list of values to use to replace the
+				 * object and method name with. Will be a
+				 * non-empty list. */
+    int fullyQualified;		/* If 1, the command name is fully qualified
+				 * and we should let the default Tcl mechanism
+				 * handle the command lookup because it is
+				 * more efficient. If 0, we need to do a
+				 * specialized lookup based on the current
+				 * object's namespace. */
 } ForwardMethod;
 
 /*
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 2606f0a..3422660 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.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: tclOOMethod.c,v 1.21 2008/12/02 19:40:41 dgp Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.22 2009/04/11 11:18:51 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -1316,6 +1316,7 @@ TclOONewForwardInstanceMethod(
 {
     int prefixLen;
     register ForwardMethod *fmPtr;
+    Tcl_Obj *cmdObj;
 
     if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
 	return NULL;
@@ -1328,6 +1329,8 @@ TclOONewForwardInstanceMethod(
 
     fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
     fmPtr->prefixObj = prefixObj;
+    Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
+    fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
     Tcl_IncrRefCount(prefixObj);
     return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
 	    nameObj, flags, &fwdMethodType, fmPtr);
@@ -1354,6 +1357,7 @@ TclOONewForwardMethod(
 {
     int prefixLen;
     register ForwardMethod *fmPtr;
+    Tcl_Obj *cmdObj;
 
     if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
 	return NULL;
@@ -1366,6 +1370,8 @@ TclOONewForwardMethod(
 
     fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
     fmPtr->prefixObj = prefixObj;
+    Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
+    fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
     Tcl_IncrRefCount(prefixObj);
     return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
 	    flags, &fwdMethodType, fmPtr);
@@ -1394,6 +1400,7 @@ InvokeForwardMethod(
     ForwardMethod *fmPtr = clientData;
     Tcl_Obj **argObjs, **prefixObjs;
     int numPrefixes, len, skip = contextPtr->skip;
+    Command *cmdPtr;
 
     /*
      * Build the real list of arguments to use. Note that we know that the
@@ -1406,8 +1413,14 @@ InvokeForwardMethod(
     argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
 	    numPrefixes, prefixObjs, &len);
 
+    if (fmPtr->fullyQualified) {
+	cmdPtr = NULL;
+    } else {
+	cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]),
+		contextPtr->oPtr->namespacePtr, 0 /* normal lookup */);
+    }
     Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
-    return Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+    return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr);
 }
 
 static int
@@ -1452,6 +1465,7 @@ CloneForwardMethod(
     ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
 
     fm2Ptr->prefixObj = fmPtr->prefixObj;
+    fm2Ptr->fullyQualified = fmPtr->fullyQualified;
     Tcl_IncrRefCount(fm2Ptr->prefixObj);
     *newClientData = fm2Ptr;
     return TCL_OK;
diff --git a/tests/oo.test b/tests/oo.test
index 6c3187b..6b81f37 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.24 2009/03/24 10:46:04 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.25 2009/04/11 11:18:51 dkf Exp $
 
 package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -448,6 +448,98 @@ test oo-6.1 {OO: forward} {
     foo destroy
     return $result
 } {1 2}
+test oo-6.2 {OO: forward resolution scope} -setup {
+    oo::class create fooClass
+} -body {
+    proc foo {} {return bad}
+    oo::define fooClass {
+	constructor {} {
+	    proc foo {} {return good}
+	}
+	forward bar foo
+    }
+    [fooClass new] bar
+} -cleanup {
+    fooClass destroy
+    rename foo {}
+} -result good
+test oo-6.3 {OO: forward resolution scope} -setup {
+    oo::class create fooClass
+} -body {
+    proc foo {} {return bad}
+    oo::define fooClass {
+	constructor {} {
+	    proc foo {} {return good}
+	}
+    }
+    oo::define fooClass forward bar foo
+    [fooClass new] bar
+} -cleanup {
+    fooClass destroy
+    rename foo {}
+} -result good
+test oo-6.4 {OO: forward resolution scope} -setup {
+    oo::class create fooClass
+} -body {
+    proc foo {} {return good}
+    oo::define fooClass {
+	constructor {} {
+	    proc foo {} {return bad}
+	}
+	forward bar ::foo
+    }
+    [fooClass new] bar
+} -cleanup {
+    fooClass destroy
+    rename foo {}
+} -result good
+test oo-6.5 {OO: forward resolution scope} -setup {
+    oo::class create fooClass
+    namespace eval foo {}
+} -body {
+    proc foo::foo {} {return good}
+    oo::define fooClass {
+	constructor {} {
+	    proc foo {} {return bad}
+	}
+	forward bar foo::foo
+    }
+    [fooClass new] bar
+} -cleanup {
+    fooClass destroy
+    namespace delete foo
+} -result good
+test oo-6.6 {OO: forward resolution scope} -setup {
+    oo::class create fooClass
+    namespace eval foo {}
+} -body {
+    proc foo::foo {} {return bad}
+    oo::define fooClass {
+	constructor {} {
+	    namespace eval foo {
+		proc foo {} {return good}
+	    }
+	}
+	forward bar foo::foo
+    }
+    [fooClass new] bar
+} -cleanup {
+    fooClass destroy
+    namespace delete foo
+} -result good
+test oo-6.7 {OO: forward resolution scope is per-object} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	constructor {} {
+	    proc curns {} {namespace current}
+	}
+	forward ns curns
+    }
+    expr {[[fooClass new] ns] ne [[fooClass new] ns]}
+} -cleanup {
+    fooClass destroy
+} -result 1
 
 test oo-7.1 {OO: inheritance 101} -setup {
     oo::class create superClass