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-2008 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.35 2010/01/28 10:25:05 dkf Exp $

package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    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}]
    }
}

proc initInterpreter name {
    $name eval [list package ifneeded TclOO [package provide TclOO] \
		    [package ifneeded TclOO [package provide TclOO]]]
}

test oo-0.1 {basic test of OO's ability to clean up its initial state} {
    interp create t
    initInterpreter t
    t eval {
	package require TclOO
    }
    interp delete t
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
    set i [interp create]
    initInterpreter $i
    interp eval $i {
	package require TclOO
	namespace delete ::
    }
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
    leaktest {
	[oo::object new] destroy
    }
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
    leaktest {
	oo::class create foo
	foo new
	foo destroy
    }
} -constraints memory -result 0
test oo-0.5 {testing literal leak on interp delete} memory {
    leaktest {
	interp create foo
	foo eval {oo::object new}
	interp delete foo
    }
} 0

test oo-1.1 {basic test of OO functionality: no classes} {
    set result {}
    lappend result [oo::object create foo]
    lappend result [oo::objdefine foo {
	method bar args {
	    global result
	    lappend result {*}$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::objdefine aninstance unexport destroy
    aninstance doesnotexist
} -cleanup {
    rename aninstance {}
} -returnCodes 1 -result {object "::aninstance" has no visible methods}
test oo-1.7 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -body {
    oo::objdefine aninstance {
	# Do not do this in real code! Ever! This is *not* supported!
	::oo::define::method ha ha ha
    }
} -returnCodes error -cleanup {
    aninstance destroy
} -result {attempt to misuse API}
test oo-1.8 {basic test of OO functionality} -setup {
    oo::object create obj
    set result {}
} -cleanup {
    obj destroy
} -body {
    oo::objdefine obj method foo {} {return bar}
    lappend result [obj foo]
    oo::objdefine obj method foo {} {}
    lappend result [obj foo]
} -result {bar {}}
test oo-1.9 {basic test of OO functionality} -setup {
    oo::object create a
    oo::object create b
} -cleanup {
    catch {a destroy}
    b destroy
} -body {
    oo::objdefine a method foo {} { return A }
    oo::objdefine b method foo {} { return B }
    apply {{} {
	set m foo
	return [a $m],[a destroy],[b $m]
    }}
} -result A,,B
test oo-1.10 {basic test of OO functionality} -body {
    namespace eval foo {
	namespace eval bar {
	    oo::object create o
	    namespace export o
	}
	namespace import bar::o
    }
    list [info object isa object foo::bar::o] [info object isa object foo::o]
} -cleanup {
    namespace delete foo
} -result {1 1}
test oo-1.11 {basic test of OO functionality: abbreviating} -setup {
    oo::class create c
} -cleanup {
    c destroy
} -body {
    oo::define c super oo::class
    info class super c
} -result ::oo::class
test oo-1.12 {basic test of OO functionality: abbreviating} -setup {
    oo::class create c
} -cleanup {
    c destroy
} -body {
    oo::define c {super oo::class}
    info class super c
} -result ::oo::class
test oo-1.13 {basic test of OO functionality: abbreviating} -setup {
    oo::class create c
} -cleanup {
    c destroy
} -body {
    oo::define c self {forw a b}
    info object forw c a
} -result b
test oo-1.14 {basic test of OO functionality: abbreviating} -setup {
    oo::class create c
} -cleanup {
    c destroy
} -body {
    oo::define c self forw a b
    info object forw c a
} -result b
test oo-1.15 {basic test of OO functionality: abbreviating} -setup {
    oo::object create o
} -cleanup {
    o destroy
} -body {
    oo::objdefine o {forw a b}
    info object forw o a
} -result b
test oo-1.16 {basic test of OO functionality: abbreviating} -setup {
    oo::object create o
} -cleanup {
    o destroy
} -body {
    oo::objdefine o forw a b
    info object forw o a
} -result b
test oo-1.17 {basic test of OO functionality: Bug 2481109} -body {
    namespace eval ::foo {oo::object create lreplace}
} -cleanup {
    namespace delete ::foo
} -result ::foo::lreplace
# Check for Bug 2519474; problem in tclNamesp.c, but tested here...
test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
    proc test-oo-1.18 {} return
    oo::class create A
    oo::class create B {superclass A}
} -body {
    oo::define B constructor {} {A create test-oo-1.18}
    B create C
} -cleanup {
    rename test-oo-1.18 {}
    A destroy
} -result ::C
test oo-1.19 {basic test of OO functionality: teardown order} -body {
    oo::object create o
    namespace delete [info object namespace o]
    o destroy
    # Crashes on error
} -returnCodes error -result {invalid command name "o"}
test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
    oo::object create obj
    rename [info object namespace obj]::my ::AGlobalName
    obj destroy
    info commands ::AGlobalName
} -result {}

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
    initInterpreter subinterp
    subinterp eval {
	package require TclOO
    }
} -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-2.4 {OO constructor - Bug 2531577} -setup {
    oo::class create foo
} -body {
    oo::define foo constructor {} return
    [foo new] destroy
    oo::define foo constructor {} {}
    llength [info command [foo new]]
} -cleanup {
    foo destroy
} -result 1
test oo-2.5 {OO constructor - Bug 2531577} -setup {
    oo::class create foo
    set result {}
} -body {
    oo::define foo constructor {} {error x}
    lappend result [catch {foo new}]
    oo::define foo constructor {} {}
    lappend result [llength [info command [foo new]]]
} -cleanup {
    foo destroy
} -result {1 1}
test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
    oo::class create foo
} -body {
    oo::define foo {
	constructor {} { tailcall my bar }
	method bar {}  { return bad }
    }
    namespace tail [foo create good]
} -cleanup {
    foo destroy
} -result good

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
    initInterpreter subinterp
    subinterp eval {
	package require TclOO
    }
} -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
    initInterpreter subinterp
    subinterp eval {
	package require TclOO
    }
} -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-3.3 {basic test of OO functionality: destructor} -setup {
    oo::class create foo
    set result {}
} -cleanup {
    foo destroy
} -body {
    oo::define foo {
	constructor {} {lappend ::result made}
	destructor {lappend ::result died}
    }
    namespace delete [info object namespace [foo new]]
    return $result
} -result {made died}
test oo-3.4 {basic test of OO functionality: my exists in destructor} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    oo::define cls {
	variable state
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	}
	forward Report lappend ::result
	destructor {
	    objmy Report [catch {set state} msg] $msg
	    objmy Report [namespace which -var state]
	    objmy Report [info commands localcmdexists]
	}
    }
    cls create obj
    rename [info object namespace obj]::my ::objmy
    obj destroy
    lappend result [info commands ::objmy]
} -match glob -result {0 ok *::state localcmdexists {}}
# Compare with previous test; the differences are because here the destructor
# is run with the namespace partially squelched.
test oo-3.5 {basic test of OO functionality: my exists in destructor} -setup {
    oo::class create cls
    set result {}
} -cleanup {
    cls destroy
} -body {
    # Order of destruction of commands relative to namespace is complex, but
    # we want to make sure that the order from the perspective of TclOO is
    # solid.
    oo::define cls {
	variable state
	constructor {} {
	    proc localcmdexists {} {}
	    set state ok
	}
	forward Report lappend ::result
	destructor {
	    objmy Report [catch {set state} msg] $msg
	    objmy Report [namespace which -var state]
	    objmy Report [info commands localcmdexists]
	}
    }
    cls create obj
    rename [info object namespace obj]::my ::objmy
    namespace delete [info object namespace obj]
    lappend result [info commands ::objmy]
} -match glob -result {1 {can't read "state": no such variable} *::state {} {}}
test oo-3.6 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
} -cleanup {
    cls destroy
} -body {
    oo::define cls destructor {error foo}
    list [catch {[cls create obj] destroy} msg] $msg [info commands obj]
} -result {1 foo {}}
test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
    set result {}
    proc bgerror msg {lappend ::result $msg}
} -cleanup {
    cls destroy
    rename bgerror {}
} -body {
    oo::define cls destructor {error foo}
    list [rename [cls create obj] {}] \
	[update idletasks] $result [info commands obj]
} -result {{} {} foo {}}
test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
    oo::class create cls
    set result {}
    proc bgerror msg {lappend ::result $msg}
} -cleanup {
    cls destroy
    rename bgerror {}
} -body {
    oo::define cls destructor {error foo}
    list [namespace delete [info object namespace [cls create obj]]] \
	[update idletasks] $result [info commands obj]
} -result {{} {} foo {}}

test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::objdefine $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::objdefine $o method foo {} {lappend ::result foo; return}
    lappend result [$o foo]
    oo::objdefine $o unexport foo
    lappend result [catch {$o foo} msg] $msg [$o destroy]
} {foo {} 1 {unknown method "foo": must be destroy} {}}
test oo-4.3 {exporting and error messages, Bug 1824958} -setup {
    oo::class create testClass
} -cleanup {
    testClass destroy
} -body {
    oo::define testClass self export Bad
    testClass Bad
} -returnCodes 1 -result {unknown method "Bad": must be create, destroy or new}
test oo-4.4 {exporting a class method from an object} -setup {
    oo::class create testClass
    testClass create testObject
} -cleanup {
    testClass destroy
} -body {
    oo::define testClass method Good {} { return ok }
    oo::objdefine testObject export Good
    testObject Good
} -result ok
test oo-4.5 {export creates proper method entries} -setup {
    oo::class create testClass
} -body {
    oo::define testClass {
	export foo
	method foo {} {return ok}
    }
    [testClass new] foo
} -cleanup {
    testClass destroy
} -result ok
test oo-4.6 {export creates proper method entries} -setup {
    oo::class create testClass
} -body {
    oo::define testClass {
	unexport foo
	method foo {} {return ok}
    }
    [testClass new] foo
} -cleanup {
    testClass destroy
} -result ok

test oo-5.1 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::objdefine oo::object method foo {} { return "in object" }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
test oo-5.2 {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::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
test oo-5.3 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::objdefine oo::object {
	method foo {} { return "in object" }
    }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
test oo-5.4 {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::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
test oo-5.5 {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::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}

test oo-6.1 {OO: forward} {
    oo::object create foo
    oo::objdefine 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-6.2 {OO: forward resolution scope} -setup {
    oo::class create fooClass
} -body {
    proc foo {} {return bad}
    oo::define fooClass {
	constructor {} {
	    proc foo {} {return good}
	}
	forward bar foo
    }
    [fooClass new] bar
} -cleanup {
    fooClass destroy
    rename foo {}
} -result good
test oo-6.3 {OO: forward resolution scope} -setup {
    oo::class create fooClass
} -body {
    proc foo {} {return bad}
    oo::define fooClass {
	constructor {} {
	    proc foo {} {return good}
	}
    }
    oo::define fooClass forward bar foo
    [fooClass new] bar
} -cleanup {
    fooClass destroy
    rename foo {}
} -result good
test oo-6.4 {OO: forward resolution scope} -setup {
    oo::class create fooClass
} -body {
    proc foo {} {return good}
    oo::define fooClass {
	constructor {} {
	    proc foo {} {return bad}
	}
	forward bar ::foo
    }
    [fooClass new] bar
} -cleanup {
    fooClass destroy
    rename foo {}
} -result good
test oo-6.5 {OO: forward resolution scope} -setup {
    oo::class create fooClass
    namespace eval foo {}
} -body {
    proc foo::foo {} {return good}
    oo::define fooClass {
	constructor {} {
	    proc foo {} {return bad}
	}
	forward bar foo::foo
    }
    [fooClass new] bar
} -cleanup {
    fooClass destroy
    namespace delete foo
} -result good
test oo-6.6 {OO: forward resolution scope} -setup {
    oo::class create fooClass
    namespace eval foo {}
} -body {
    proc foo::foo {} {return bad}
    oo::define fooClass {
	constructor {} {
	    namespace eval foo {
		proc foo {} {return good}
	    }
	}
	forward bar foo::foo
    }
    [fooClass new] bar
} -cleanup {
    fooClass destroy
    namespace delete foo
} -result good
test oo-6.7 {OO: forward resolution scope is per-object} -setup {
    oo::class create fooClass
} -body {
    oo::define fooClass {
	constructor {} {
	    proc curns {} {namespace current}
	}
	forward ns curns
    }
    expr {[[fooClass new] ns] ne [[fooClass new] ns]}
} -cleanup {
    fooClass destroy
} -result 1

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::objdefine 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::objdefine 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 {
	superclass oo::class
	self {
	    unexport create new
	    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 {
	superclass other oo::class
	self {
	    unexport create new
	    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 {
    unset -nocomplain x
    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::objdefine 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-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 foo; lappend ::result [next] foo}
    }
    oo::class create foo2 {
	superclass foo
	method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
    }
    lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
    set ::result {}
    oo::class create ::master
    namespace eval ::foo {
	oo::class create mixin {superclass ::master}
    }
} -cleanup {
    ::master destroy
    namespace delete ::foo
} -body {
    namespace eval ::foo {
	oo::class create bar {superclass master}
	oo::class create boo
	oo::define boo {superclass bar}
	oo::define boo {mixin mixin}
	oo::class create spong {superclass boo}
	return
    }
} -result {}

test oo-8.1 {OO: global must work in methods} {
    oo::object create foo
    oo::objdefine 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::objdefine O method foo x {
	lappend ::result -$x-
	if {$x == 1} {
	    oo::objdefine O deletemethod foo
	}
	next $x
    }
    set result {}
    O foo 2
    return $result
} -result {-2- 2 -1- 1 0}
test oo-10.2 {OO: recursive invoke and modify} -setup {
    oo::object create O
} -cleanup {
    O destroy
} -body {
    oo::objdefine O method foo {} {
	oo::objdefine [self] method foo {} {
	    error "not called"
	}
	return [format %s%s call ed]
    }
    O foo
} -result called
test oo-10.3 {OO: invoke and modify} -setup {
    oo::class create A {
	method a {} {return A.a}
	method b {} {return A.b}
	method c {} {return A.c}
    }
    oo::class create B {
	superclass A
	method a {} {return [next],B.a}
	method b {} {return [next],B.b}
	method c {} {return [next],B.c}
    }
    B create C
    set result {}
} -cleanup {
    A destroy
} -body {
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b
    lappend result [C a] [C b] [C c] -
    oo::define B renamemethod a b
    lappend result [C a] [C b] [C c] -
    oo::define B deletemethod b c
    lappend result [C a] [C b] [C c]
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}

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 {*}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {*}$args]
	    lappend result "result=$r"
	    return $r
	}
    }
    oo::objdefine 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 {*}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {*}$args]
	    lappend result "result=$r"
	    return $r
	}
    }
    oo::objdefine 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 {*}$args
	    join $args {}
	}
	method logFilter args {
	    global result
	    lappend result "calling [self object]->[self method] $args"
	    set r [next {*}$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::objdefine foo 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::objdefine foo 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::objdefine foo class oo::object
} -cleanup {
    foo destroy
} -returnCodes 1 -result {may not change a class object into a non-class object}
test oo-13.4 {OO: changing an object's class} -body {
    oo::class create foo {
	method m {} {
	    set result [list [self class] [info object class [self]]]
	    oo::objdefine [self] class ::bar
	    lappend result [self class] [info object class [self]]
	}
    }
    oo::class create bar
    [foo new] m
} -cleanup {
    foo destroy
    bar destroy
} -result {::foo ::foo ::foo ::bar}
# 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::objdefine [Aclass create fooTest] mixin Bclass
    oo::objdefine [Aclass create fooTest2] mixin Bclass
    set result [list [catch {fooTest ?} msg] $msg]
    fooTest bar
    fooTest boo
    fooTest2 bar
    fooTest2 boo
    oo::objdefine 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-14.3 {OO and mixins and filters - advanced case} -setup {
    oo::class create mix
    oo::class create c {
	mixin mix
    }
    c create i
} -body {
    oo::define mix {
	method foo {} {return >>[next]<<}
	filter foo
    }
    oo::objdefine i method bar {} {return foobar}
    i bar
} -cleanup {
    mix destroy
    if {[info object isa object i]} {
	error "mixin deletion failed to destroy dependent instance"
    }
} -result >>foobar<<
test oo-14.4 {OO: mixin error case} -setup {
    oo::class create c
} -body {
    oo::define c mixin c
} -returnCodes error -cleanup {
    c destroy
} -result {may not mix a class into itself}
test oo-14.5 {OO and mixins and filters - advanced case} -setup {
    oo::class create mix
    oo::class create c {
	mixin mix
    }
    c create i
} -body {
    oo::define mix {
	method foo {} {return >>[next]<<}
	filter foo
    }
    oo::objdefine i method bar {} {return foobar}
    i bar
} -cleanup {
    c destroy
    mix destroy
} -result >>foobar<<
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create A {
	superclass master
	method egg {} {
	    return chicken
	}
    }
    oo::class create B {
	superclass master
	mixin A
	method bar {} {
	    # mixin from A
	    my egg
	}
    }
    oo::class create C {
	superclass master
	mixin B
	method foo {} {
	    # mixin from B
	    my bar
	}
    }
    [C new] foo
} -result chicken
test oo-14.7 {OO and filters from mixins of mixins} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create A {
	superclass master
	method egg {} {
	    return chicken
	}
	filter f
	method f args {
	    set m [lindex [self target] 1]
	    return "($m) [next {*}$args] ($m)"
	}
    }
    oo::class create B {
	superclass master
	mixin A
	filter f
	method bar {} {
	    # mixin from A
	    my egg
	}
    }
    oo::class create C {
	superclass master
	mixin B
	filter f
	method foo {} {
	    # mixin from B
	    my bar
	}
    }
    [C new] foo
} -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 {
	method test {} {}
    }
} -cleanup {
    master destroy
} -body {
    oo::class create mix {
	superclass master
	method test {} {lappend ::result mix; next; return $::result}
    }
    oo::class create cls {
	superclass master
	mixin mix
	method test {} {lappend ::result cls; next; return $::result}
    }
    [cls new] test
} -result {mix cls}

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::copy Ainstance Binstance
    Binstance test
    Ainstance test
    Ainstance destroy
    namespace eval foo {
	oo::copy Binstance 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::objdefine 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::copy foo 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::copy foo 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 subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \
	      [info object class instance1] \
	      [info object class instance2]] \
	[list [info object isa class oo::object] \
	     [info object isa class meta] \
	     [info object isa class instance1] \
	     [info object isa class instance2]] \
	[list [info object isa metaclass oo::object] \
	     [info object isa metaclass oo::class] \
	     [info object isa metaclass meta] \
	     [info object isa metaclass instance1] \
	     [info object isa metaclass instance2]] \
	[list [info object isa object oo::object] \
	     [info object isa object oo::class] \
	     [info object isa object meta] \
	     [info object isa object instance1] \
	     [info object isa object instance2] \
	     [info object isa object oo::define] \
	     [info object isa object NOTANOBJECT]]
} -cleanup {
    meta destroy
} -result {{::oo::class ::oo::class ::oo::class ::meta ::instance1} {1 1 1 0} {0 1 1 0 0} {1 1 1 1 1 0 0}}
test oo-16.5 {OO: object introspection} {info object methods oo::object} {}
test oo-16.6 {OO: object introspection} {
    oo::object create foo
    set result [list [info object methods foo]]
    oo::objdefine foo method bar {} {...}
    lappend result [info object methods foo] [foo destroy]
} {{} bar {}}
test oo-16.7 {OO: object introspection} -setup {
    oo::object create foo
} -body {
    oo::objdefine foo method bar {a {b c} args} {the body}
    set result [info object methods foo]
    lappend result [info object definition foo 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::objdefine foo mixin bar
    set result [list [info object mixins foo] \
		    [info object isa mixin foo bar] \
		    [info object isa mixin foo oo::class]]
    foo destroy
    bar destroy
    return $result
} {::bar 1 0}
test oo-16.9 {OO: object introspection} -body {
    oo::class create Ac
    oo::class create Bc; oo::define Bc superclass Ac
    oo::class create Cc; oo::define Cc superclass Bc
    oo::class create Dc; oo::define Dc mixin Cc
    Cc create E
    Dc create F
    list [info object isa    typeof E oo::class] \
	    [info object isa typeof E Ac] \
	    [info object isa typeof F Bc] \
	    [info object isa typeof F Cc]
} -cleanup {
    catch {Ac destroy}
} -result {0 1 1 1}
test oo-16.10 {OO: object introspection} -setup {
    oo::object create foo
} -body {
    oo::objdefine foo export eval
    foo eval {variable c 3 a 1 b 2 ddd 4 e}
    lsort [info object vars foo ?]
} -cleanup {
    foo destroy
} -result {a b c}
test oo-16.11 {OO: object introspection} -setup {
    oo::class create foo
    foo create bar
} -body {
    oo::define foo method spong {} {...}
    oo::objdefine bar method boo {a {b c} args} {the body}
    list [info object methods bar -all] [info object methods bar -all -private]
} -cleanup {
    foo destroy
} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
test oo-16.12 {OO: object introspection} -setup {
    oo::object create foo
} -cleanup {
    rename foo {}
} -body {
    oo::objdefine foo unexport {*}[info object methods foo -all]
    info object methods foo -all
} -result {}
test oo-16.13 {OO: object introspection} -setup {
    oo::object create foo
} -cleanup {
    rename foo {}
} -body {
    oo::objdefine foo method Bar {} {return "ok in foo"}
    [info object namespace foo]::my Bar
} -result "ok in foo"

test oo-17.1 {OO: class introspection} -body {
    info class
} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
test oo-17.2 {OO: class introspection} -body {
    info class superclass NOTANOBJECT
} -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 superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, superclasses, or variables}
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 instances testClass]
} -cleanup {
    testClass destroy
} -result {::bar ::foo ::spong}
test oo-17.6 {OO: class introspection} -setup {
    oo::class create foo
} -body {
    oo::define foo method bar {a {b c} args} {the body}
    set result [info class methods foo]
    lappend result [info class definition foo bar]
} -cleanup {
    foo destroy
} -result {bar {{a {b c} args} {the body}}}
test oo-17.7 {OO: class introspection} {
    info class superclasses oo::class
} ::oo::object
test oo-17.8 {OO: class introspection} -setup {
    oo::class create testClass
    oo::class create superClass1
    oo::class create superClass2
} -body {
    oo::define testClass superclass superClass1 superClass2
    list [info class superclasses testClass] \
	[lsort [info class subclass oo::object ::superClass?]]
} -cleanup {
    testClass destroy
    superClass1 destroy
    superClass2 destroy
} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}
test oo-17.9 {OO: class introspection} -setup {
    oo::class create foo
    oo::class create subfoo {superclass foo}
} -body {
    oo::define foo {
	method bar {a {b c} args} {the body}
	self {
	    method bad {} {...}
	}
    }
    oo::define subfoo method boo {a {b c} args} {the body}
    list [info class methods subfoo -all] \
	[info class methods subfoo -all -private]
} -cleanup {
    foo destroy
} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
test oo-17.10 {OO: class introspection} -setup {
    oo::class create foo
} -cleanup {
    rename foo {}
} -body {
    oo::define foo unexport {*}[info class methods foo -all]
    info class methods foo -all
} -result {}

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.3a {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 2)
    invoked from within
"oo::class create foo {
    error bar
}"}}
test oo-18.3b {OO: define command support} {
    list [catch {oo::class create foo {
    eval eval error bar
}} msg] $msg $errorInfo
} {1 bar {bar
    while executing
"error bar"
    ("eval" body line 1)
    invoked from within
"eval error bar"
    ("eval" body line 1)
    invoked from within
"eval eval error bar"
    (in definition script for object "::foo" line 2)
    invoked from within
"oo::class create foo {
    eval eval error bar
}"}}
test oo-18.4 {OO: more error traces from the guts} -setup {
    oo::object create obj
} -body {
    oo::objdefine 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::objdefine 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::objdefine inst export eval
    set result {}
    inst eval { variable x }
} -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-19.2 {OO: varname method: Bug 2883857} -setup {
    oo::class create SpecialClass
    oo::objdefine SpecialClass export createWithNamespace
    SpecialClass createWithNamespace inst ::oo_test
    oo::objdefine inst export varname eval
} -body {
    inst eval { variable x; array set x {y z} }
    inst varname x(y)
} -cleanup {
    SpecialClass destroy
} -result ::oo_test::x(y)

test oo-20.1 {OO: variable method} -body {
    oo::class create testClass {
	constructor {} {
	    my variable ok
	    set ok {}
	}
    }
    lsort [info object vars [testClass new]]
} -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 vars [testClass new]]
} -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 {
	export varname
	self export eval
    }
} -body {
    testClass eval variable a 0
    oo::objdefine [testClass create foo] method bar {other} {
	$other variable a
	set a 3
    }
    oo::objdefine [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 d b
	    lappend b $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}
# oo-20.8 tested explicitly for functionality removed due to [Bug 1959457]
test oo-20.9 {OO: variable method} -setup {
    oo::object create obj
} -body {
    oo::objdefine obj {
	method a {} {
	    my variable ::b
	}
    }
    obj a
} -returnCodes 1 -cleanup {
    obj destroy
} -result {variable name "::b" illegal: must not contain namespace separator}
test oo-20.10 {OO: variable and varname methods refer to same things} -setup {
    oo::object create obj
} -body {
    oo::objdefine obj {
	method a {} {
	    my variable b
	    set b [self]
	    return [my varname b]
	}
    }
    list [set [obj a]] [namespace tail [obj a]]
} -cleanup {
    obj destroy
} -result {::obj b}
test oo-20.11 {OO: variable mustn't crash when recursing} -body {
    oo::class create A {
	constructor {name} {
	    my variable np_name 
	    set np_name $name
	}
	method copy {nm} {
	    set cpy [[info object class [self]] new $nm]
	    foreach var [info object vars [self]] {
		my variable $var
		set val [set $var]
		if {[string match o_* $var]} {
		    set objs {}
		    foreach ref $val {
			# call to "copy" crashes
			lappend objs [$ref copy {}]
		    }
		    $cpy prop $var $objs
		} else { 
		    $cpy prop $var $val
		}
	    }
	    return $cpy
	}
	method prop {name val} {
	    my variable $name
	    set $name $val
	}
    }
    set o1 [A new {}]
    set o2 [A new {}]
    $o1 prop o_object $o2
    $o1 copy aa
} -cleanup {
    catch {A destroy}
} -match glob -result *
test oo-20.12 {OO: variable method accept zero args (TIP 323)} -setup {
    oo::object create foo
} -cleanup {
    foo destroy
} -body {
    oo::objdefine foo method demo {} {
	my variable
    }
    foo demo
} -result {}
test oo-20.13 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable
} -cleanup {
    fooObj destroy
} -body {
    apply {{} {fooObj variable x; set x ok; return}}
    apply {{} {fooObj variable x; return $x}}
} -result ok
test oo-20.14 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable
    namespace eval ns1 {}
    namespace eval ns2 {}
    set x bad
} -cleanup {
    fooObj destroy
    namespace delete ns1 ns2
    unset x
} -body {
    namespace eval ns1 {fooObj variable x; set x ok; subst ""}
    set x bad
    namespace eval ns2 {fooObj variable x; return $x}
} -result ok
test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup {
    oo::object create fooObj
    oo::objdefine fooObj export variable varname
} -cleanup {
    fooObj destroy
} -body {
    apply {{} {fooObj variable x; set x ok; return}}
    return [set [fooObj varname x]]
} -result ok

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::objdefine 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::objdefine o {
	method m {} {lappend ::result o;next}
	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::objdefine 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::objdefine 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}

test oo-22.1 {OO and info frame} -setup {
    oo::class create c
    c create i
} -match glob -body {
    oo::define c self method frame {} {
	info frame 0
    }
    oo::define c {
	method frames {} {
	    info frame 0
	}
	method level {} {
	    info frame
	}
    }
    oo::objdefine i {
	method frames {} {
	    list [next] [info frame 0]
	}
	method level {} {
	    expr {[next] - [info frame]}
	}
    }
    list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
    c destroy
} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}

# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
    oo::class create SELF {
	superclass oo::class
	unexport create new
	# Next is just a convenience
	method method args {oo::define [self] method {*}$args}
	method derive {name} {
	    set o [my new [list superclass [self]]]
	    oo::objdefine $o mixin $o
	    uplevel 1 [list rename $o $name]\;[list namespace which $name]
	}
	self mixin SELF
    }
    set result {}
} -body {
    [SELF derive foo1] method bar1 {} {return 1}
    lappend result [foo1 bar1]
    [foo1 derive foo2] method bar2 {} {return [my bar1],2}
    lappend result [foo2 bar2]
    [foo2 derive foo3] method bar3 {} {return [my bar2],3}
    lappend result [foo3 bar3]
    [foo3 derive foo4] method bar4 {} {return [my bar3],4}
    lappend result [foo4 bar4]
    foo2 method bar2 {} {return [my bar1],x}
    lappend result [foo4 bar4]
} -cleanup {
    SELF destroy
} -result {1 1,2 1,2,3 1,2,3,4 1,x,3,4}

test oo-24.1 {unknown method method - Bug 1965063} -setup {
    oo::class create cls
} -cleanup {
    cls destroy
} -returnCodes error -body {
    oo::define cls {
	method dummy {} {}
	method unknown args {next {*}$args}
    }
    [cls new] foo bar
} -result {unknown method "foo": must be destroy, dummy or unknown}
test oo-24.2 {unknown method method - Bug 1965063} -setup {
    oo::class create cls
} -cleanup {
    cls destroy
} -returnCodes error -body {
    oo::define cls {
	method dummy {} {}
	method unknown args {next {*}$args}
    }
    cls create obj
    oo::objdefine obj {
	method dummy2 {} {}
	method unknown args {next {*}$args}
    }
    obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}

# Probably need a better set of tests, but this is quite difficult to devise
test oo-25.1 {call chain caching} -setup {
    oo::class create cls {
	method ab {} {return ok}
    }
    set result {}
} -cleanup {
    cls destroy
} -body {
    cls create foo
    cls create bar
    set m1 ab
    set m2 a; append m2 b ;# different object!
    lappend result [foo $m1] [foo $m1] [bar $m1] [foo $m1]
    lappend result [foo $m2] [bar $m2]
    oo::objdefine foo method ab {} {return good}
    lappend result [foo $m1] [bar $m2]
} -result {ok ok ok ok ok ok good ok}
test oo-25.2 {call chain caching - Bug #2120903} -setup {
    set c [oo::class create MyClass]
    set o [$c new]
} -body {
    oo::define MyClass {
	method name {} {return ok}
	method isa o {MyClass name $o}
	self method name o {$o name}
    }
    list [$o name] [$c name $o] [$o isa $o]
} -cleanup {
    $c destroy
} -result {ok ok ok}

test oo-26.1 {Bug 2037727} -setup {
    proc succeed args {}
    oo::object create example
} -body {
    oo::objdefine example method foo {} {succeed}
    example foo
    proc succeed {} {return succeed}
    example foo
} -cleanup {
    example destroy
    rename succeed {}
} -result succeed
test oo-26.2 {Bug 2037727} -setup {
    oo::class create example {
	method localProc {args body} {proc called $args $body}
	method run {} { called }
    }
    example create i1
    example create i2
} -body {
    i1 localProc args {}
    i2 localProc args {return nonempty}
    list [i1 run] [i2 run]
} -cleanup {
    example destroy
} -result {{} nonempty}
test oo-26.3 {Bug 2037727} -setup {
    oo::class create example {
	method subProc {args body} {
	    namespace eval subns [list proc called $args $body]
	}
	method run {} { subns::called }
    }
    example create i1
    example create i2
} -body {
    i1 subProc args {}
    i2 subProc args {return nonempty}
    list [i1 run] [i2 run]
} -cleanup {
    example destroy
} -result {{} nonempty}

test oo-27.1 {variables declaration - class introspection} -setup {
    oo::class create foo
} -cleanup {
    foo destroy
} -body {
    oo::define foo variable a b c
    info class variables foo
} -result {a b c}
test oo-27.2 {variables declaration - object introspection} -setup {
    oo::object create foo
} -cleanup {
    foo destroy
} -body {
    oo::objdefine foo variable a b c
    info object variables foo
} -result {a b c}
test oo-27.3 {variables declaration - basic behaviour} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
    }
    foo create bar
    bar y
    bar y
} -result 3
test oo-27.4 {variables declaration - destructors too} -setup {
    oo::class create master
    set result bad!
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
	destructor {set ::result ${x!}}
    }
    foo create bar
    bar y
    bar y
    bar destroy
    return $result
} -result 3
test oo-27.5 {variables declaration - object-bound variables} -setup {
    oo::object create foo
} -cleanup {
    foo destroy
} -body {
    oo::objdefine foo {
	variable x!
	method y {} {incr x!}
    }
    foo y
    foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
    }
    foo create bar
    oo::objdefine bar {
	variable y!
	method y {} {list [next] [incr y!] [info var] [info local]}
	export eval
    }
    bar y
    list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
} -result {{3 2 y! {}} {x! y!} {x! y!}}
test oo-27.7 {variables declaration - one underlying variable space} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
    }
    oo::class create foo2 {
	superclass foo
	variable y!
	constructor {} {set y! 42; next}
	method x {} {incr y! -1}
    }
    foo2 create bar
    oo::objdefine bar {
	variable x! y!
	method z {} {list ${x!} ${y!}}
    }
    bar y
    bar x
    list [bar y] [bar x] [bar z]
} -result {3 40 {3 40}}
test oo-27.8 {variables declaration - error cases - ns separators} -body {
    oo::define oo::object variable bad::var
} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
test oo-27.9 {variables declaration - error cases - arrays} -body {
    oo::define oo::object variable bad(var)
} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable clsvar
	constructor {} {
	    set clsvar 0
	}
	method step {} {
	    incr clsvar
	    return
	}
	method value {} {
	    return $clsvar
	}
    }
    foo create inst1
    inst1 step
    foo create inst2
    inst2 step
    inst1 step
    inst2 step
    inst1 step
    list [inst1 value] [inst2 value]
} -result {3 2}
test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable clsvar
	constructor {} {
	    set clsvar 0
	}
	method step {} {
	    incr clsvar
	    return
	}
	method value {} {
	    return $clsvar
	}
    }
    foo create inst1
    oo::objdefine inst1 {
	variable clsvar
	method reinit {} {
	    set clsvar 0
	}
    }
    foo create inst2
    oo::objdefine inst2 {
	variable clsvar
	method reinit {} {
	    set clsvar 0
	}
    }
    inst1 step
    inst2 step
    inst1 reinit
    inst2 reinit
    inst1 step
    inst2 step
    inst1 step
    inst2 step
    inst1 step
    list [inst1 value] [inst2 value]
} -result {3 2}

# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
test oo-28.1 {scripted extensions to oo::define} -setup {
    interp create foo
    foo eval {oo::class create cls {export eval}}
} -cleanup {
    interp delete foo
} -body {
    foo eval {
	proc oo::define::privateMethod {name arguments body} {
	    uplevel 1 [list method $name $arguments $body]
	    uplevel 1 [list unexport $name]
	}
	oo::define cls privateMethod m {x y} {return $x,$y}
	cls create obj
	list [catch {obj m 1 2}] [obj eval my m 3 4]
    }
} -result {1 3,4}

test oo-29.1 {self class with object-defined methods} -setup {
    oo::object create obj
} -body {
    oo::objdefine obj method demo {} {
	self class
    }
    obj demo
} -returnCodes error -cleanup {
    obj destroy
} -result {method not defined by a class}

test oo-30.1 {Bug 2903011: deleting an object in a constructor} -setup {
    oo::class create cls
} -body {
    oo::define cls {constructor {} {[self] destroy}}
    cls new
} -returnCodes error -cleanup {
    cls destroy
} -result {object deleted in constructor}
test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup {
    oo::class create cls
} -body {
    oo::define cls {constructor {} {my destroy}}
    cls new
} -returnCodes error -cleanup {
    cls destroy
} -result {object deleted in constructor}

cleanupTests
return

# Local Variables:
# mode: tcl
# End: