Make [next] work as described in TIP. [Bug 1998244]

4 files changed, 34 insertions, 19 deletions

diff --git a/ChangeLog b/ChangeLog
index 82b3192..1f23d2c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2008-06-19  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclOO.c (Tcl_ObjectContextInvokeNext): Corrected 'next' (at
+	* tests/oo.test (oo-7.8):	end of a call chain) to make it
+	* doc/next.n:			consistent with the TIP. [Bug 1998244]
+
 	* generic/tclOOCall.c (AddSimpleClassChainToCallContext): Make sure
 	* tests/oo.test (oo-14.8): that class mixins are processed in the
 	documented order. [Bug 1998221]
diff --git a/doc/next.n b/doc/next.n
index a312764..898b79b 100644
--- a/doc/next.n
+++ b/doc/next.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: next.n,v 1.1 2008/05/31 11:42:13 dkf Exp $
+'\" RCS: @(#) $Id: next.n,v 1.2 2008/06/19 21:29:03 dkf Exp $
 '\"
 .so man.macros
 .TH next n 0.1 TclOO "TclOO Commands"
@@ -29,7 +29,7 @@ point where a filter calls the actual implementation (the filter may decide to
 not go along the chain, and may process the results of going along the chain
 of methods as it chooses). The result of the \fBnext\fR command is the result
 of the next method in the method chain; if there are no further methods in the
-method chain, the result of \fBnext\fR is the empty string. The arguments,
+method chain, the result of \fBnext\fR will be an error. The arguments,
 \fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the
 chain.
 .SH "THE METHOD CHAIN"
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 667210b..2b892af 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.8 2008/06/12 06:29:17 das Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.9 2008/06/19 21:29:03 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -1952,13 +1952,22 @@ Tcl_ObjectContextInvokeNext(
 
     if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
 	/*
-	 * We're at the end of the chain; return the empty string (the most
-	 * useful thing we can do, since it turns out that it's not always
-	 * trivial to detect in source code whether there is a parent
-	 * implementation, what with multiple-inheritance...)
+	 * We're at the end of the chain; generate an error message.
 	 */
 
-	return TCL_OK;
+	const char *methodType;
+
+	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+	    methodType = "constructor";
+	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+	    methodType = "destructor";
+	} else {
+	    methodType = "method";
+	}
+
+	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
+		NULL);
+	return TCL_ERROR;
     }
 
     /*
diff --git a/tests/oo.test b/tests/oo.test
index 0362647..3f9fa94 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.6 2008/06/19 20:57:23 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.7 2008/06/19 21:29:04 dkf Exp $
 
 package require TclOO 0.4 ;# Must match value in configure.in
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -558,20 +558,20 @@ test oo-7.7 {OO: inheritance and errorInfo} -setup {
     (object "::c" method "foo" line 1)
     invoked from within
 "c foo"}}
-test oo-7.8 {OO: next at the end of the method chain} {
+test oo-7.8 {OO: next at the end of the method chain} -setup {
+    set ::result ""
+} -cleanup {
+    foo destroy
+} -body {
     oo::class create foo {
-	method bar {} {lappend ::result [next] foo}
+	method bar {} {lappend ::result foo; lappend ::result [next] foo}
     }
     oo::class create foo2 {
 	superclass foo
-	method bar {} {lappend ::result [next] foo2}
+	method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
     }
-    set o [foo2 new]
-    set ::result ""
-    catch {$o bar}
-    foo destroy
-    return $result
-} {{} foo {{} foo} foo2}
+    lappend result [catch {[foo2 new] bar} msg] $msg
+} -result {foo2 foo 1 {no next method implementation}}
 
 test oo-8.1 {OO: global must work in methods} {
     oo::object create foo
@@ -1041,7 +1041,9 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup {
 } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)}
 test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
     set ::result {}
-    oo::class create master
+    oo::class create master {
+	method test {} {}
+    }
 } -cleanup {
     master destroy
 } -body {