summaryrefslogtreecommitdiffstats
path: root/tests/ooNext2.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/ooNext2.test')
-rw-r--r--tests/ooNext2.test279
1 files changed, 278 insertions, 1 deletions
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index e78e0d0..6a48d28 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.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.
-package require -exact TclOO 0.7 ;# Must match value in configure.in
+package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
@@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup {
} -cleanup {
leaktester destroy
} -constraints memory -result 0
+test oo-call-1.20 {object call introspection - complex case} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ }
+ oo::class create ::C {
+ superclass root
+ method x {} {}
+ mixin B
+ }
+ oo::class create ::D {
+ superclass C
+ method x {} {}
+ }
+ oo::class create ::E {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::F {
+ superclass E
+ method x {} {}
+ }
+ oo::class create ::G {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::H {
+ superclass G
+ method x {} {}
+ }
+ oo::define F mixin H
+ F create y
+ oo::objdefine y {
+ method x {} {}
+ mixin D
+ }
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}}
+test oo-call-1.21 {object call introspection - complex case} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method y {} {}
+ }
+ oo::class create ::C {
+ superclass root
+ method x {} {}
+ mixin B
+ }
+ oo::class create ::D {
+ superclass C
+ filter x
+ }
+ oo::class create ::E {
+ superclass root
+ method y {} {}
+ method x {} {}
+ }
+ oo::class create ::F {
+ superclass E
+ method z {} {}
+ method q {} {}
+ }
+ F create y
+ oo::objdefine y {
+ method unknown {} {}
+ mixin D
+ filter q
+ }
+ info object call y z
+} -cleanup {
+ root destroy
+} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}}
test oo-call-2.1 {class call introspection} -setup {
oo::class create root
@@ -779,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup {
} -cleanup {
root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
+
+# Contributed tests from aspect, related to [0f42ff7871]
+#
+# dkf's "Principles Leading to a Fix"
+#
+# A method ought to work "the same" whether or not it has been overridden by
+# a subclass. A tailcalled command ought to have as parent stack the same
+# thing you'd get with uplevel 1. A subclass will often expect the
+# superclass's result to be the result that would be returned if the
+# subclass was not there.
+
+# Common setup:
+# any invocation of bar should emit "abc\nhi\n" then return to its
+# caller
+set testopts {
+ -setup {
+ oo::class create Master
+ oo::class create Foo {
+ superclass Master
+ method bar {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Master
+ }
+ }
+ -cleanup {
+ Master destroy
+ }
+}
+
+# these succeed, showing that without [next] the bug doesn't fire
+test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
+ [Foo create foo] bar
+} -output [join {abc hi} \n]\n
+test next-tailcall-simple-2 "my bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ my bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ [self] bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-4 "foo bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ foo bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+
+# everything from here on uses [next], and fails on 8.6.4 with compilation
+test next-tailcall-superclass-1 "next superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ nextto Foo
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-mixin-1 "class mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ oo::define Foo mixin Foo2
+ Foo create foo
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ Foo create foo
+ oo::objdefine foo mixin Foo2
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-filter-1 "filter method" {*}$testopts -body {
+ oo::define Foo method Filter {} {
+ puts a
+ next
+ puts b
+ }
+ oo::define Foo filter Filter
+ [Foo new] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-forward-1 "forward method" {*}$testopts -body {
+ proc foobar {} {
+ puts "abc"
+ tailcall puts "hi"
+ puts "xyz"
+ }
+ oo::define Foo forward foobar foobar
+ oo::define Foo2 {
+ superclass Foo
+ method foobar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 new] foobar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-constructor-1 "next in constructor" -body {
+ oo::class create Foo {
+ constructor {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ constructor {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ list [Foo new] [Foo2 new]
+ return ""
+} -cleanup {
+ Foo destroy
+} -output [join {abc hi a abc hi b} \n]\n
+
+test next-tailcall-destructor-1 "next in destructor" -body {
+ oo::class create Foo {
+ destructor {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ destructor {
+ puts a
+ next
+ puts b
+ }
+ }
+ Foo create foo
+ Foo2 create foo2
+ foo destroy
+ foo2 destroy
+} -output [join {abc hi a abc hi b} \n]\n -cleanup {
+ Foo destroy
+}
+
+unset testopts
cleanupTests
return