diff options
Diffstat (limited to 'tests/ooNext2.test')
| -rw-r--r-- | tests/ooNext2.test | 279 |
1 files changed, 278 insertions, 1 deletions
diff --git a/tests/ooNext2.test b/tests/ooNext2.test index a47aa91..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 TclOO 1.0.1 +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 |