path: root/tests/oo.test

# 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 Donal K. Fellows
#
# 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.2 2006/10/20 14:04:01 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]

test oo-0.1 {basic test of OO's ability to clean up its initial state} {
    interp create t
    interp delete t
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
    interp eval [interp create] { namespace delete :: }
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	[oo::object new] destroy
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
} -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	oo::class create foo
	foo new
	foo destroy
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
} -result 0

test oo-1.1 {basic test of OO functionality: no classes} {
    set result {}
    lappend result [oo::object create foo]
    lappend result [oo::define foo {
	method bar args {
	    global result
	    lappend result {expand}$args
	    return [llength $args]
	}
    }]
    lappend result [foo bar a b c]
    lappend result [foo destroy] [info commands foo]
} {::foo {} a b c 3 {} {}}
test oo-1.2 {basic test of OO functionality: no classes} -body {
    oo::define oo::object method missingArgs
} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
test oo-1.3 {basic test of OO functionality: no classes} {
    catch {oo::define oo::object method missingArgs}
    set errorInfo
} "wrong # args: should be \"oo::define oo::object method name args body\"
    while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
test oo-1.6 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -body {
    oo::define aninstance unexport destroy
    aninstance doesnotexist
} -cleanup {
    rename aninstance {}
} -returnCodes 1 -result {object "::aninstance" has no visible methods}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
} -body {
    subinterp eval {
	oo::define oo::object constructor {} {
	    lappend ::result [info level 0]
	}
	lappend result 1
	lappend result 2 [oo::object create foo]
    }
} -cleanup {
    interp delete subinterp
} -result {1 {oo::object create foo} 2 ::foo}
test oo-2.2 {basic test of OO functionality: constructor} {
    oo::class create testClass {
	constructor {} {
	    global result
	    lappend result "[self]->construct"
	}
	method bar {} {
	    global result
	    lappend result "[self]->bar"
	}
    }
    set result {}
    [testClass create foo] bar
    testClass destroy
    return $result
} {::foo->construct ::foo->bar}

test oo-3.1 {basic test of OO functionality: destructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
} -body {
    subinterp eval {
	oo::define oo::object destructor {
	    lappend ::result died
	}
	lappend result 1 [oo::object create foo]
	lappend result 2 [rename foo {}]
	oo::define oo::object destructor {}
	return $result
    }
} -cleanup {
    interp delete subinterp
} -result {1 ::foo died 2 {}}
test oo-3.2 {basic test of OO functionality: destructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
} -body {
    subinterp eval {
	oo::define oo::object destructor {
	    lappend ::result died
	}
	lappend result 1 [oo::object create foo]
	lappend result 2 [rename foo {}]
    }
} -cleanup {
    interp delete subinterp
} -result {1 ::foo died 2 {}}

test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::define $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::define $o export Foo
    lappend result [$o Foo] [$o destroy]
} {1 {unknown method "Foo": must be destroy} Foo {} {}}
test oo-4.2 {basic test of OO functionality: unexport} {
    set o [oo::object new]
    set result {}
    oo::define $o method foo {} {lappend ::result foo; return}
    lappend result [$o foo]
    oo::define $o unexport foo
    lappend result [catch {$o foo} msg] $msg [$o destroy]
} {foo {} 1 {unknown method "foo": must be destroy} {}}

test oo-5.1 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::define oo::object self.method foo {} { return "in object" }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::define oo::object self.method foo {} {}
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}

test oo-6.1 {OO: forward} {
    oo::object create foo
    oo::define foo {
	forward a lappend
	forward b lappend result
    }
    set result {}
    foo a result 1
    foo b 2
    foo destroy
    return $result
} {1 2}

test oo-7.1 {OO: inheritance 101} -setup {
    oo::class create superClass
    oo::class create subClass
    subClass create instance
} -body {
    oo::define superClass method doit x {lappend ::result $x}
    oo::define subClass superclass superClass
    set result [list [catch {subClass doit bad} msg] $msg]
    instance doit ok
    return $result
} -cleanup {
    subClass destroy
    superClass destroy
} -result {1 {unknown method "doit": must be create, destroy or new} ok}
test oo-7.2 {OO: inheritance 101} -setup {
    oo::class create superClass
    oo::class create subClass
    subClass create instance
} -body {
    oo::define superClass method doit x {lappend ::result |$x|}
    oo::define subClass superclass superClass
    oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
    set result {}
    instance doit 1
    return $result
} -cleanup {
    subClass destroy
    superClass destroy
} -result {=1= |2|}
test oo-7.3 {OO: inheritance 101} -setup {
    oo::class create superClass
    oo::class create subClass
    subClass create instance
} -body {
    oo::define superClass method doit x {lappend ::result |$x|}
    oo::define subClass {
	superclass superClass
	method doit x {lappend ::result -$x-; next [incr x]}
    }
    oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
    set result {}
    instance doit 1
    return $result
} -cleanup {
    subClass destroy
    superClass destroy
} -result {=1= -2- |3|}
test oo-7.4 {OO: inheritance from oo::class} -body {
    oo::class create meta
    oo::define meta {
	superclass oo::class
	self.unexport create new
	self.method make {x {definitions {}}} {
	    if {![string match ::* $x]} {
		set ns [uplevel 1 {::namespace current}]
		set x ${ns}::$x
	    }
	    set o [my create $x]
	    lappend ::result "made $o"
	    oo::define $o $definitions
	    return $o
	}
    }
    set result [list [catch {meta create foo} msg] $msg]
    lappend result [meta make classinstance {
	lappend ::result "in definition script in [namespace current]"
    }]
    lappend result [classinstance create instance]
} -cleanup {
    catch {classinstance destroy}
    catch {meta destroy}
} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
    oo::class create other
    oo::class create meta
    oo::define meta {
	superclass other oo::class
	self.unexport create new
	self.method make {x {definitions {}}} {
	    if {![string match ::* $x]} {
		set ns [uplevel 1 {::namespace current}]
		set x ${ns}::$x
	    }
	    set o [my create $x]
	    lappend ::result "made $o"
	    oo::define $o $definitions
	    return $o
	}
    }
    set result [list [catch {meta create foo} msg] $msg]
    lappend result [meta make classinstance {
	lappend ::result "in definition script in [namespace current]"
    }]
    lappend result [classinstance create instance]
} -cleanup {
    catch {classinstance destroy}
    catch {meta destroy}
    catch {other destroy}
} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
    oo::class create Aclass
    oo::class create Bclass
    Bclass create Binstance
} -body {
    oo::define Aclass {
	method incr {var step} {
	    upvar 1 $var v
	    ::incr v $step
	}
    }
    oo::define Bclass {
	superclass Aclass
	method incr {var {step 1}} {
	    global result
	    lappend result $var $step
	    set r [next $var $step]
	    lappend result returning:$r
	    return $r
	}
    }
    set result {}
    set x 10
    lappend result x=$x
    lappend result [Binstance incr x]
    lappend result x=$x
} -result {x=10 x 1 returning:11 11 x=11} -cleanup {
    Aclass destroy
}
test oo-7.7 {OO: inheritance and errorInfo} -setup {
    oo::class create A
    oo::class create B
    B create c
} -body {
    oo::define A method foo {} {error foo!}
    oo::define B {
	superclass A
	method foo {} { next }
    }
    oo::define c method foo {} { next }
    catch {c ?} msg
    set result [list $msg]
    catch {c foo} msg
    lappend result $msg $errorInfo
} -cleanup {
    A destroy
} -result {{unknown method "?": must be destroy or foo} foo! {foo!
    while executing
"error foo!"
    (class "::A" method "foo" line 1)
    invoked from within
"next "
    (class "::B" method "foo" line 1)
    invoked from within
"next "
    (object "::c" method "foo" line 1)
    invoked from within
"c foo"}}

test oo-8.1 {OO: global must work in methods} {
    oo::object create foo
    oo::define foo method bar x {global result; lappend result $x}
    set result {}
    foo bar this
    foo bar is
    lappend result a
    foo bar test
    foo destroy
    return $result
} {this is a test}

test oo-9.1 {OO: multiple inheritance} -setup {
    oo::class create A
    oo::class create B
    oo::class create C
    oo::class create D
    D create foo
} -body {
    oo::define A method test {} {lappend ::result A; return ok}
    oo::define B {
	superclass A
	method test {} {lappend ::result B; next}
    }
    oo::define C {
	superclass A
	method test {} {lappend ::result C; next}
    }
    oo::define D {
	superclass B C
	method test {} {lappend ::result D; next}
    }
    set result {}
    lappend result [foo test]
} -cleanup {
    D destroy
    C destroy
    B destroy
    A destroy
} -result {D B C A ok}
test oo-9.2 {OO: multiple inheritance} -setup {
    oo::class create A
    oo::class create B
    oo::class create C
    oo::class create D
    D create foo
} -body {
    oo::define A method test {} {lappend ::result A; return ok}
    oo::define B {
	superclass A
	method test {} {lappend ::result B; next}
    }
    oo::define C {
	superclass A
	method test {} {lappend ::result C; next}
    }
    oo::define D {
	superclass B C
	method test {} {lappend ::result D; next}
    }
    set result {}
    lappend result [foo test]
} -cleanup {
    A destroy
} -result {D B C A ok}

test oo-10.1 {OO: recursive invoke and modify} -setup {
    [oo::class create C] create O
} -cleanup {
    C destroy
} -body {
    oo::define C method foo x {
	lappend ::result $x
	if {$x} {
	    [self object] foo [incr x -1]
	}
    }
    oo::define O method foo x {
	lappend ::result -$x-
	if {$x == 1} {
	    # delete the method
	    oo::define O method foo {} {}
	}
	next $x
    }
    set result {}
    O foo 2
    return $result
} -result {-2- 2 -1- 1 0}

test oo-11.1 {OO: cleanup} {
    oo::object create foo
    set result [list [catch {oo::object create foo} msg] $msg]
    lappend result [foo destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.2 {OO: cleanup} {
    oo::class create bar
    bar create foo
    set result [list [catch {bar create foo} msg] $msg]
    lappend result [bar destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.3 {OO: cleanup} {
    oo::class create bar0
    oo::class create bar
    oo::define bar superclass bar0
    bar create foo
    set result [list [catch {bar create foo} msg] $msg]
    lappend result [bar0 destroy] [oo::object create foo] [foo destroy]
} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
test oo-11.4 {OO: cleanup} {
    oo::class create bar0
    oo::class create bar1
    oo::define bar1 superclass bar0
    oo::class create bar2
    oo::define bar2 {
	superclass bar0
	destructor {lappend ::result destroyed}
    }
    oo::class create bar
    oo::define bar superclass bar1 bar2
    bar create foo
    set result [list [catch {bar create foo} msg] $msg]
    lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
	[oo::object create bar2] [bar2 destroy]
} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}

test oo-12.1 {OO: filters} {
    oo::class create Aclass
    Aclass create Aobject
    oo::define Aclass {
	method concatenate args {
	    global result
	    lappend result {expand}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {expand}$args]
	    lappend result "result=$r"
	    return $r
	}
    }
    oo::define Aobject filter logFilter
    set result {}
    lappend result [Aobject concatenate 1 2 3 4 5]
    Aclass destroy
    return $result
} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345}
test oo-12.2 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method concatenate args {
	    global result
	    lappend result {expand}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {expand}$args]
	    lappend result "result=$r"
	    return $r
	}
    }
    oo::define Aobject filter logFilter
    set result {}
    lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
} -cleanup {
    Aclass destroy
} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
test oo-12.3 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method concatenate args {
	    global result
	    lappend result {expand}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {expand}$args]
	    lappend result "result=$r"
	    return $r
	}
	filter logFilter
    }
    set result {}
    lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
} -cleanup {
    Aclass destroy
} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
test oo-12.4 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method foo {} { return foo }
	method Bar {} { return 1 }
	method boo {} { if {[my Bar]} { next } { error forbidden } }
	filter boo
    }
    Aobject foo
} -cleanup {
    Aclass destroy
} -result foo
test oo-12.5 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method foo {} { return foo }
	method Bar {} { return [my Bar2] }
	method Bar2 {} { return 1 }
	method boo {} { if {[my Bar]} { next } { error forbidden } }
	filter boo
    }
    Aobject foo
} -cleanup {
    Aclass destroy
} -result foo
test oo-12.6 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method foo {} { return foo }
	method Bar {} { return [my Bar2] }
	method Bar2 {} { return [my Bar3] }
	method Bar3 {} { return 1 }
	method boo {} { if {[my Bar]} { next } { error forbidden } }
	filter boo
    }
    Aobject foo
} -cleanup {
    Aclass destroy
} -result foo
test oo-12.7 {OO: filters} -setup {
    oo::class create Aclass
    Aclass create Aobject
} -body {
    oo::define Aclass {
	method outerfoo {} { return [my InnerFoo] }
	method InnerFoo {} { return foo }
	method Bar {} { return [my Bar2] }
	method Bar2 {} { return [my Bar3] }
	method Bar3 {} { return 1 }
	method boo {} {
	    lappend ::log [self target]
	    if {[my Bar]} { next } else { error forbidden }
	}
	filter boo
    }
    set log {}
    list [Aobject outerfoo] $log
} -cleanup {
    Aclass destroy
} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}

test oo-13.1 {OO: changing an object's class} {
    oo::class create Aclass
    oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
    oo::class create Bclass
    oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
    set result [Aclass create foo]
    foo bar
    oo::define foo self.class Bclass
    foo bar
    Aclass destroy
    lappend result [info command foo]
    Bclass destroy
    return $result
} {::foo {in A ::foo} {in B ::foo} foo}
test oo-13.2 {OO: changing an object's class} -body {
    oo::object create foo
    oo::define foo self.class oo::class
} -cleanup {
    foo destroy
} -returnCodes 1 -result {may not change a non-class object into a class object}
test oo-13.3 {OO: changing an object's class} -body {
    oo::class create foo
    oo::define foo self.class oo::object
} -cleanup {
    foo destroy
} -returnCodes 1 -result {may not change a class object into a non-class object}
# todo: changing a class subtype (metaclass) to another class subtype

test oo-14.1 {OO: mixins} {
    oo::class create Aclass
    oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
    oo::class create Bclass
    oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
    oo::define [Aclass create fooTest] mixin Bclass
    oo::define [Aclass create fooTest2] mixin Bclass
    set result [list [catch {fooTest ?} msg] $msg]
    fooTest bar
    fooTest boo
    fooTest2 bar
    fooTest2 boo
    oo::define fooTest2 mixin
    lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
test oo-14.2 {OO: mixins} {
    oo::class create Aclass {
	method bar {} {return "[self object] in bar"}
    }
    oo::class create Bclass {
	method boo {} {return "[self object] in boo"}
    }
    oo::define Aclass mixin Bclass
    Aclass create fooTest
    set result [list [catch {fooTest ?} msg] $msg]
    lappend result [catch {fooTest bar} msg] $msg
    lappend result [catch {fooTest boo} msg] $msg
    lappend result [Bclass destroy] [info commands Aclass]
} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}

test oo-15.1 {OO: object cloning} {
    oo::class create Aclass
    oo::define Aclass method test {} {lappend ::result [self object]->test}
    Aclass create Ainstance
    set result {}
    Ainstance test
    oo::define Ainstance copy Binstance
    Binstance test
    Ainstance test
    Ainstance destroy
    namespace eval foo {
	oo::define Binstance copy Cinstance
	Cinstance test
    }
    Aclass destroy
    namespace delete foo
    lappend result [info commands Binstance]
} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}}
test oo-15.2 {OO: object cloning} {
    oo::object create foo
    oo::define foo {
	method m x {lappend ::result [self object] >$x<}
	forward f ::lappend ::result fwd
    }
    set result {}
    foo m 1
    foo f 2
    lappend result [oo::define foo copy bar]
    foo m 3
    foo f 4
    bar m 5
    bar f 6
    lappend result [foo destroy]
    bar m 7
    bar f 8
    lappend result [bar destroy]
} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}}
catch {foo destroy}
catch {bar destroy}
test oo-15.3 {OO: class cloning} {
    oo::class create foo {
	method testme {} {lappend ::result [self class]->[self object]}
    }
    set result {}
    foo create baseline
    baseline testme
    oo::define foo copy bar
    baseline testme
    bar create tester
    tester testme
    foo destroy
    tester testme
    bar destroy
    return $result
} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}

test oo-16.1 {OO: object introspection} -body {
    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object objName subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object NOTANOBJECT class
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object oo::object gorp
} -returnCodes 1 -result {bad subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
} -body {
    list [info object oo::object class] \
	[info object oo::class class] \
	[info object oo::object isa class] \
	[info object oo::object isa metaclass] \
	[info object meta isa metaclass] \
	[info object oo::object isa object] \
	[info object oo::define isa object]
} -cleanup {
    meta destroy
} -result {::oo::class ::oo::class 1 0 1 1 0}
test oo-16.5 {OO: object introspection} {info object oo::object methods} {}
test oo-16.6 {OO: object introspection} {
    oo::object create foo
    set result [list [info object foo methods]]
    oo::define foo method bar {} {...}
    lappend result [info object foo methods] [foo destroy]
} {{} bar {}}
test oo-16.7 {OO: object introspection} -setup {
    oo::object create foo
} -body {
    oo::define foo method bar {a {b c} args} {the body}
    set result [info object foo methods]
    lappend result [info object foo definition bar]
} -cleanup {
    foo destroy
} -result {bar {{a {b c} args} {the body}}}
test oo-16.8 {OO: object introspection} {
    oo::object create foo
    oo::class create bar
    oo::define foo mixin bar
    set result [list [info object foo mixins] \
		    [info object foo isa mixin bar] \
		    [info object foo isa mixin oo::class]]
    foo destroy
    bar destroy
    return $result
} {::bar 1 0}
test oo-16.9 {OO: object introspection} {
    oo::class create Ac
    oo::class create Bc; oo::define Bc superclass Ac
    oo::class create Cc; oo::define Cc superclass Bc
    Cc create D
    list [info object D isa typeof oo::class] \
		    [info object D isa typeof Ac] [Ac destroy]
} {0 1 {}}
test oo-16.10 {OO: object introspection} -setup {
    oo::object create foo
} -body {
    oo::define foo export eval
    foo eval {variable c 3 a 1 b 2 ddd 4 e}
    lsort [info object foo vars ?]
} -cleanup {
    foo destroy
} -result {a b c}

test oo-17.1 {OO: class introspection} -body {
    info class
} -returnCodes 1 -result "wrong \# args: should be \"info class className subcommand ?arg ...?\""
test oo-17.2 {OO: class introspection} -body {
    info class NOTANOBJECT gorp
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-17.3 {OO: class introspection} -setup {
    oo::object create foo
} -body {
    info class foo gorp
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class oo::object gorp
} -returnCodes 1 -result {bad subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class testClass instances]
} -cleanup {
    testClass destroy
} -result {::bar ::foo ::spong}
test oo-17.6 {OO: object introspection} -setup {
    oo::class create foo
} -body {
    oo::define foo method bar {a {b c} args} {the body}
    set result [info class foo methods]
    lappend result [info class foo definition bar]
} -cleanup {
    foo destroy
} -result {bar {{a {b c} args} {the body}}}
test oo-17.7 {OO: object introspection} {
    info class oo::class superclasses
} ::oo::object
test oo-17.8 {OO: object introspection} -setup {
    oo::class create testClass
    oo::class create superClass1
    oo::class create superClass2
} -body {
    oo::define testClass superclass superClass1 superClass2
    list [info class testClass superclasses] \
	[lsort [info class oo::object subclass ::superClass?]]
} -cleanup {
    testClass destroy
    superClass1 destroy
    superClass2 destroy
} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}

test oo-18.1 {OO: define command support} {
    list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
    while executing
"error foo"
    (in definition script for object "oo::object" line 1)
    invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
    list [catch {oo::define oo::object error foo} msg] $msg $errorInfo
} {1 foo {foo
    while executing
"oo::define oo::object error foo"}}
test oo-18.3 {OO: define command support} {
    list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo
} {1 bar {bar
    while executing
"error bar"
    (in definition script for object "::foo" line 1)
    invoked from within
"oo::class create foo {error bar}"}}
test oo-18.4 {OO: more error traces from the guts} -setup {
    oo::object create obj
} -body {
    oo::define obj method bar {} {my eval {error foo}}
    list [catch {obj bar} msg] $msg $errorInfo
} -cleanup {
    obj destroy
} -result {1 foo {foo
    while executing
"error foo"
    (in "my eval" script line 1)
    invoked from within
"my eval {error foo}"
    (object "::obj" method "bar" line 1)
    invoked from within
"obj bar"}}
test oo-18.5 {OO: more error traces from the guts} -setup {
    [oo::class create cls] create obj
    set errorInfo {}
} -body {
    oo::define cls {
	method eval script {next $script}
	export eval
    }
    oo::define obj method bar {} {my eval {error foo}}
    set result {}
    lappend result [catch {obj bar} msg] $msg $errorInfo
    lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo
} -cleanup {
    cls destroy
} -result {1 foo {foo
    while executing
"error foo"
    (in "my eval" script line 1)
    invoked from within
"next $script"
    (class "::cls" method "eval" line 1)
    invoked from within
"my eval {error foo}"
    (object "::obj" method "bar" line 1)
    invoked from within
"obj bar"} 1 bar {bar
    while executing
"error bar"
    (in "::obj eval" script line 1)
    invoked from within
"next $script"
    (class "::cls" method "eval" line 1)
    invoked from within
"obj eval {error bar}"}}

test oo-19.1 {OO: varname method} -setup {
    oo::object create inst
    oo::define inst export eval
    set result {}
} -body {
    inst eval {trace add variable x write foo}
    set ns [inst eval namespace current]
    proc foo args {
	global ns result
	set context [uplevel 1 namespace current]
	lappend result $args [expr {
	    $ns eq $context ? "ok" : [list $ns ne $context]
	}] [expr {
	    "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]]
	}]
    }
    lappend result [inst eval set x 0]
} -cleanup {
    inst destroy
    rename foo {}
} -result {{x {} write} ok ok 0}

test oo-20.1 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable ok
	    set ok {}
	}
    }
    lsort [info object [testClass new] vars]
} -cleanup {
    catch {testClass destroy}
} -result ok
test oo-20.2 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable a b c
	    set a [set b [set c {}]]
	}
    }
    lsort [info object [testClass new] vars]
} -cleanup {
    catch {testClass destroy}
} -result {a b c}
test oo-20.3 {OO: variable method} -body {
    oo::class create testClass {
	export varname
	method bar {} {
	    my variable a(b)
	}
    }
    testClass create foo
    array set [foo varname a] {b c}
    foo bar
} -returnCodes 1 -cleanup {
    catch {testClass destroy}
} -result {can't define "a(b)": name refers to an element in an array}
test oo-20.4 {OO: variable method} -body {
    oo::class create testClass {
	export varname
	method bar {} {
	    my variable a(b)
	}
    }
    testClass create foo
    set [foo varname a] b
    foo bar
} -returnCodes 1 -cleanup {
    catch {testClass destroy}
} -result {can't define "a(b)": name refers to an element in an array}
test oo-20.5 {OO: variable method} -body {
    oo::class create testClass {
	method bar {} {
	    my variable a::b
	}
    }
    testClass create foo
    foo bar
} -returnCodes 1 -cleanup {
    catch {testClass destroy}
} -result {variable name "a::b" illegal: must not contain namespace separator}
test oo-20.6 {OO: variable method} -setup {
    oo::class create testClass {
	self.export eval
	export varname
    }
} -body {
    testClass eval variable a 0
    oo::define [testClass create foo] method bar {other} {
	$other variable a
	set a 3
    }
    oo::define [testClass create boo] export variable
    set [foo varname a] 1
    set [boo varname a] 2
    foo bar boo
    list [testClass eval set a] [set [foo varname a]] [set [boo varname a]]
} -cleanup {
    testClass destroy
} -result {0 1 3}
test oo-20.7 {OO: variable method} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	method a {} {
	    my variable {b c} d
	    lappend c $d
	}
	method e {} {
	    my variable b d
	    return [list $b $d]
	}
	method f {x y} {
	    my variable b d
	    set b $x
	    set d $y
	}
    }
    cls create obj
    obj f p q
    obj a
    obj a
    obj e
} -cleanup {
    cls destroy
} -result {{p q q} q}
test oo-20.8 {OO: variable method} -setup {
    oo::class create cls
} -body {
    oo::define cls {
	constructor {} {
	    namespace eval foo {
		variable bar 1
	    }
	}
	method ns {} {self namespace}
	method a {} {
	    my variable {foo::bar c} d
	    lappend c $d
	}
	method e {} {
	    my variable {foo::bar b} d
	    return [list $b $d]
	}
	method f {x} {
	    my variable d
	    set d $x
	}
    }
    cls create obj
    obj f p
    obj a
    obj a
    list [obj e] [set [obj ns]::foo::bar]
} -cleanup {
    cls destroy
} -result {{{1 p p} p} {1 p p}}
test oo-20.9 {OO: variable method} -setup {
    oo::object create obj
} -body {
    oo::define obj {
	method a {} {
	    my variable {a ::b}
	}
    }
    obj a
} -cleanup {
    obj destroy
} -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator}

test oo-21.1 {OO: inheritance ordering} -setup {
    oo::class create A
} -body {
    oo::define A method m {} {lappend ::result A}
    oo::class create B {
	superclass A
	method m {} {lappend ::result B;next}
    }
    oo::class create C {
	superclass A
	method m {} {lappend ::result C;next}
    }
    oo::class create D {
	superclass B C
	method m {} {lappend ::result D;next}
    }
    D create o
    oo::define o method m {} {lappend ::result o;next}
    set result {}
    o m
    return $result
} -cleanup {
    A destroy
} -result {o D B C A}
test oo-21.2 {OO: inheritance ordering} -setup {
    oo::class create A
} -body {
    oo::define A method m {} {lappend ::result A}
    oo::class create B {
	superclass A
	method m {} {lappend ::result B;next}
    }
    oo::class create C {
	superclass A
	method m {} {lappend ::result C;next}
    }
    oo::class create D {
	superclass B C
	method m {} {lappend ::result D;next}
    }
    oo::class create Emix {
	superclass C
	method m {} {lappend ::result Emix;next}
    }
    oo::class create Fmix {
	superclass Emix
	method m {} {lappend ::result Fmix;next}
    }
    D create o
    oo::define o method m {} {lappend ::result o;next}
    oo::define o mixin Fmix
    set result {}
    o m
    return $result
} -cleanup {
    A destroy
} -result {Fmix Emix o D B C A}
test oo-21.3 {OO: inheritance ordering} -setup {
    oo::class create A
} -body {
    oo::define A method m {} {lappend ::result A}
    oo::class create B {
	superclass A
	method m {} {lappend ::result B;next}
	method f {} {lappend ::result B-filt;next}
    }
    oo::class create C {
	superclass A
	method m {} {lappend ::result C;next}
    }
    oo::class create D {
	superclass B C
	method m {} {lappend ::result D;next}
    }
    oo::class create Emix {
	superclass C
	method m {} {lappend ::result Emix;next}
	method f {} {lappend ::result Emix-filt;next}
    }
    oo::class create Fmix {
	superclass Emix
	method m {} {lappend ::result Fmix;next}
    }
    D create o
    oo::define o {
	method m {} {lappend ::result o;next}
	mixin Fmix
	filter f
    }
    set result {}
    o m
    return $result
} -cleanup {
    A destroy
} -result {Emix-filt B-filt Fmix Emix o D B C A}
test oo-21.4 {OO: inheritance ordering} -setup {
    oo::class create A
} -body {
    oo::define A method m {} {lappend ::result A}
    oo::class create B {
	superclass A
	method m {} {lappend ::result B;next}
	method f {} {lappend ::result B-filt;next}
	method g {} {lappend ::result B-cfilt;next}
    }
    oo::class create C {
	superclass A
	method m {} {lappend ::result C;next}
    }
    oo::class create D {
	superclass B C
	method m {} {lappend ::result D;next}
	method g {} {lappend ::result D-cfilt;next}
	filter g
    }
    oo::class create Emix {
	superclass C
	method m {} {lappend ::result Emix;next}
	method f {} {lappend ::result Emix-filt;next}
    }
    oo::class create Fmix {
	superclass Emix
	method m {} {lappend ::result Fmix;next}
    }
    D create o
    oo::define o {
	method m {} {lappend ::result o;next}
	mixin Fmix
	filter f
    }
    set result {}
    o m
    return $result
} -cleanup {
    A destroy
} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A}

cleanupTests
return

# Local Variables:
# mode: tcl
# End: