--- /dev/null
+# This file contains a collection of tests for Tcl's built-in object system.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2006-2011 Donal K. Fellows
+#
+# 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.3
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
+
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ set lines [split [memory info] \n]
+ return [lindex $lines 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
+\f
+test oo-nextto-1.1 {basic nextto functionality} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x args {
+ lappend ::result ==A== $args
+ }
+ }
+ oo::class create B {
+ superclass A
+ method x args {
+ lappend ::result ==B== $args
+ nextto A B -> A {*}$args
+ }
+ }
+ oo::class create C {
+ superclass A
+ method x args {
+ lappend ::result ==C== $args
+ nextto A C -> A {*}$args
+ }
+ }
+ oo::class create D {
+ superclass B C
+ method x args {
+ lappend ::result ==D== $args
+ next foo
+ nextto C bar
+ }
+ }
+ set ::result {}
+ [D new] x
+ return $::result
+} -cleanup {
+ root destroy
+} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}}
+test oo-nextto-1.2 {basic nextto functionality} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x args {
+ lappend ::result ==A== $args
+ }
+ }
+ oo::class create B {
+ superclass A
+ method x args {
+ lappend ::result ==B== $args
+ nextto A B -> A {*}$args
+ }
+ }
+ oo::class create C {
+ superclass A
+ method x args {
+ lappend ::result ==C== $args
+ nextto A C -> A {*}$args
+ }
+ }
+ oo::class create D {
+ superclass B C
+ method x args {
+ lappend ::result ==D== $args
+ nextto B foo {*}$args
+ nextto C bar {*}$args
+ }
+ }
+ set ::result {}
+ [D new] x 123
+ return $::result
+} -cleanup {
+ root destroy
+} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}}
+test oo-nextto-1.3 {basic nextto functionality: constructors} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ variable result
+ constructor {a c} {
+ lappend result ==A== a=$a,c=$c
+ }
+ }
+ oo::class create B {
+ superclass root
+ variable result
+ constructor {b} {
+ lappend result ==B== b=$b
+ }
+ }
+ oo::class create C {
+ superclass A B
+ variable result
+ constructor {p q r} {
+ lappend result ==C== p=$p,q=$q,r=$r
+ # Route arguments to superclasses, in non-trival pattern
+ nextto B $q
+ nextto A $p $r
+ }
+ method result {} {return $result}
+ }
+ [C new x y z] result
+} -cleanup {
+ root destroy
+} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z}
+test oo-nextto-1.4 {basic nextto functionality: destructors} -setup {
+ oo::class create root {destructor return}
+} -body {
+ oo::class create A {
+ superclass root
+ destructor {
+ lappend ::result ==A==
+ next
+ }
+ }
+ oo::class create B {
+ superclass root
+ destructor {
+ lappend ::result ==B==
+ next
+ }
+ }
+ oo::class create C {
+ superclass A B
+ destructor {
+ lappend ::result ==C==
+ lappend ::result |
+ nextto B
+ lappend ::result |
+ nextto A
+ lappend ::result |
+ next
+ }
+ }
+ set ::result ""
+ [C new] destroy
+ return $::result
+} -cleanup {
+ root destroy
+} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==}
+
+test oo-nextto-2.1 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {error $y}
+ }
+ oo::class create B {
+ superclass A
+ method x y {nextto A $y}
+ }
+ [B new] x boom
+} -cleanup {
+ root destroy
+} -result boom -returnCodes error
+test oo-nextto-2.2 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {error $y}
+ }
+ oo::class create B {
+ superclass root
+ method x y {nextto A $y}
+ }
+ [B new] x boom
+} -returnCodes error -cleanup {
+ root destroy
+} -result {method has no non-filter implementation by "A"}
+test oo-nextto-2.3 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {nextto $y}
+ }
+ oo::class create B {
+ superclass A
+ method x y {nextto A $y}
+ }
+ [B new] x B
+} -returnCodes error -cleanup {
+ root destroy
+} -result {method implementation by "B" not reachable from here}
+test oo-nextto-2.4 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {nextto $y}
+ }
+ oo::class create B {
+ superclass A
+ method x y {nextto}
+ }
+ [B new] x B
+} -returnCodes error -cleanup {
+ root destroy
+} -result {wrong # args: should be "nextto class ?arg...?"}
+test oo-nextto-2.5 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {nextto $y}
+ }
+ oo::class create B {
+ superclass A
+ method x y {nextto $y $y $y}
+ }
+ [B new] x A
+} -cleanup {
+ root destroy
+} -result {wrong # args: should be "nextto A y"} -returnCodes error
+test oo-nextto-2.6 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {nextto $y}
+ }
+ oo::class create B {
+ superclass A
+ method x y {nextto $y $y $y}
+ }
+ [B new] x [root create notAClass]
+} -cleanup {
+ root destroy
+} -result {"::notAClass" is not a class} -returnCodes error
+test oo-nextto-2.7 {errors in nextto} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x y {nextto $y}
+ }
+ oo::class create B {
+ superclass A
+ filter Y
+ method Y args {next {*}$args}
+ }
+ oo::class create C {
+ superclass B
+ method x y {nextto $y $y $y}
+ }
+ [C new] x B
+} -returnCodes error -cleanup {
+ root destroy
+} -result {method has no non-filter implementation by "B"}
+
+test oo-call-1.1 {object call introspection} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ A create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{method x ::A method}}
+test oo-call-1.2 {object call introspection} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ }
+ B create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{method x ::B method} {method x ::A method}}
+test oo-call-1.3 {object call introspection} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ A create y
+ oo::objdefine y method x {} {}
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{method x object method} {method x ::A method}}
+test oo-call-1.4 {object object call introspection - unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ A create y
+ info object call y z
+} -cleanup {
+ root destroy
+} -result {{unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.5 {object call introspection - filters} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ A create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::A method} {method x ::A method}}
+test oo-call-1.6 {object call introspection - filters} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ }
+ B create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.7 {object call introspection - filters} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ method y {} {}
+ }
+ B create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.8 {object call introspection - filters} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ method y {} {}
+ method z {} {}
+ filter z
+ }
+ B create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.9 {object call introspection - filters} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ method y {} {}
+ method z {} {}
+ filter z
+ }
+ B create y
+ info object call y y
+} -cleanup {
+ root destroy
+} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}}
+test oo-call-1.10 {object call introspection - filters + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method y {} {}
+ method unknown {} {}
+ }
+ B create y
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.11 {object call introspection - filters + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ filter y
+ }
+ A create y
+ oo::objdefine y method unknown {} {}
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.12 {object call introspection - filters + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ }
+ A create y
+ oo::objdefine y {
+ method unknown {} {}
+ filter y
+ }
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.13 {object call introspection - filters + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ }
+ A create y
+ oo::objdefine y {
+ method unknown {} {}
+ method x {} {}
+ filter y
+ }
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{filter y ::A method} {method x object method}}
+test oo-call-1.14 {object call introspection - errors} -body {
+ info object call
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.15 {object call introspection - errors} -body {
+ info object call a
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.16 {object call introspection - errors} -body {
+ info object call a b c
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.17 {object call introspection - errors} -body {
+ info object call notanobject x
+} -returnCodes error -result {notanobject does not refer to an object}
+test oo-call-1.18 {object call introspection - memory leaks} -body {
+ leaktest {
+ info object call oo::object destroy
+ }
+} -constraints memory -result 0
+test oo-call-1.19 {object call introspection - memory leaks} -setup {
+ oo::class create leaktester { method foo {} {dummy} }
+} -body {
+ leaktest {
+ set lt [leaktester new]
+ oo::objdefine $lt method foobar {} {dummy}
+ list [info object call $lt destroy] \
+ [info object call $lt foo] \
+ [info object call $lt bar] \
+ [info object call $lt foobar] \
+ [$lt destroy]
+ }
+} -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
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ info class call A x
+} -cleanup {
+ root destroy
+} -result {{method x ::A method}}
+test oo-call-2.2 {class call introspection} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ }
+ list [info class call A x] [info class call B x]
+} -cleanup {
+ root destroy
+} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}}
+test oo-call-2.3 {class call introspection} -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 A
+ method x {} {}
+ }
+ oo::class create ::D {
+ superclass C B
+ method x {} {}
+ }
+ info class call D x
+} -cleanup {
+ root destroy
+} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}}
+test oo-call-2.4 {class call introspection - mixin} -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 A
+ method x {} {}
+ }
+ oo::class create ::D {
+ superclass C
+ mixin B
+ method x {} {}
+ }
+ info class call D x
+} -cleanup {
+ root destroy
+} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
+test oo-call-2.5 {class call introspection - mixin + filter} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::C {
+ superclass A
+ method x {} {}
+ method y {} {}
+ }
+ oo::class create ::D {
+ superclass C
+ mixin B
+ method x {} {}
+ }
+ info class call D x
+} -cleanup {
+ root destroy
+} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
+test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ method unknown {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ method y {} {}
+ filter y
+ }
+ oo::class create ::C {
+ superclass A
+ method x {} {}
+ method y {} {}
+ }
+ oo::class create ::D {
+ superclass C
+ mixin B
+ method x {} {}
+ method unknown {} {}
+ }
+ info class call D z
+} -cleanup {
+ root destroy
+} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ filter x
+ }
+ info class call B x
+} -cleanup {
+ root destroy
+} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-2.8 {class call introspection - errors} -body {
+ info class call
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.9 {class call introspection - errors} -body {
+ info class call a
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.10 {class call introspection - errors} -body {
+ info class call a b c
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.11 {class call introspection - errors} -body {
+ info class call notaclass x
+} -returnCodes error -result {notaclass does not refer to an object}
+test oo-call-2.12 {class call introspection - errors} -setup {
+ oo::class create root
+} -body {
+ root create notaclass
+ info class call notaclass x
+} -returnCodes error -cleanup {
+ root destroy
+} -result {"notaclass" is not a class}
+test oo-call-2.13 {class call introspection - memory leaks} -body {
+ leaktest {
+ info class call oo::class destroy
+ }
+} -constraints memory -result 0
+test oo-call-2.14 {class call introspection - memory leaks} -body {
+ leaktest {
+ oo::class create leaktester { method foo {} {dummy} }
+ [leaktester new] destroy
+ list [info class call leaktester destroy] \
+ [info class call leaktester foo] \
+ [info class call leaktester bar] \
+ [leaktester destroy]
+ }
+} -constraints memory -result 0
+
+test oo-call-3.1 {current call introspection} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ method x {} {lappend ::result [self call]}
+ }
+ oo::class create B {
+ superclass A
+ method x {} {lappend ::result [self call];next}
+ }
+ B create y
+ oo::objdefine y method x {} {lappend ::result [self call];next}
+ set ::result {}
+ y x
+} -cleanup {
+ root destroy
+} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}}
+test oo-call-3.2 {current call introspection} -setup {
+ oo::class create root
+} -constraints memory -body {
+ oo::class create A {
+ superclass root
+ method x {} {self call}
+ }
+ oo::class create B {
+ superclass A
+ method x {} {self call;next}
+ }
+ B create y
+ oo::objdefine y method x {} {self call;next}
+ leaktest {
+ y x
+ }
+} -cleanup {
+ root destroy
+} -result 0
+test oo-call-3.3 {current call introspection: in constructors} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ constructor {} {lappend ::result [self call]}
+ }
+ oo::class create B {
+ superclass A
+ constructor {} {lappend ::result [self call]; next}
+ }
+ set ::result {}
+ [B new] destroy
+ return $::result
+} -cleanup {
+ root destroy
+} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}}
+test oo-call-3.4 {current call introspection: in destructors} -setup {
+ oo::class create root
+} -body {
+ oo::class create A {
+ superclass root
+ destructor {lappend ::result [self call]}
+ }
+ oo::class create B {
+ superclass A
+ destructor {lappend ::result [self call]; next}
+ }
+ set ::result {}
+ [B new] destroy
+ return $::result
+} -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 Parent
+ oo::class create Foo {
+ superclass Parent
+ method bar {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Parent
+ }
+ }
+ -cleanup {
+ Parent 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
+\f
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
OSDN Git Service
