summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2008-06-19 21:29:02 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2008-06-19 21:29:02 (GMT)
commit48bde53d60eb4631746456df0bd1e879c6a15628 (patch)
tree9865c18bcd5f93f18cbc931b62b13c329a89b915
parent107e7f1dfc29d890846a46317dca00e49594393c (diff)
downloadtcl-48bde53d60eb4631746456df0bd1e879c6a15628.zip
tcl-48bde53d60eb4631746456df0bd1e879c6a15628.tar.gz
tcl-48bde53d60eb4631746456df0bd1e879c6a15628.tar.bz2
Make [next] work as described in TIP. [Bug 1998244]
-rw-r--r--ChangeLog4
-rw-r--r--doc/next.n4
-rw-r--r--generic/tclOO.c21
-rw-r--r--tests/oo.test24
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 {