# 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.59 2011/01/18 16:10:48 dkf Exp $

package require -exact TclOO 0.6.2 ;# Must match value in configure.in
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}]
    }
}

test oo-nextto-1.1 {basic nextto functionality} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x args {
	    lappend ::result ==A== $args
	}
    }
    oo::class create B {
	superclass A
	method x args {
	    lappend ::result ==B== $args
	    nextto A B -> A {*}$args
	}
    }
    oo::class create C {
	superclass A
	method x args {
	    lappend ::result ==C== $args
	    nextto A C -> A {*}$args
	}
    }
    oo::class create D {
	superclass B C
	method x args {
	    lappend ::result ==D== $args
	    next foo
	    nextto C bar
	}
    }
    set ::result {}
    [D new] x
    return $::result
} -cleanup {
    root destroy
} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}}
test oo-nextto-1.2 {basic nextto functionality} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x args {
	    lappend ::result ==A== $args
	}
    }
    oo::class create B {
	superclass A
	method x args {
	    lappend ::result ==B== $args
	    nextto A B -> A {*}$args
	}
    }
    oo::class create C {
	superclass A
	method x args {
	    lappend ::result ==C== $args
	    nextto A C -> A {*}$args
	}
    }
    oo::class create D {
	superclass B C
	method x args {
	    lappend ::result ==D== $args
	    nextto B foo {*}$args
	    nextto C bar {*}$args
	}
    }
    set ::result {}
    [D new] x 123
    return $::result
} -cleanup {
    root destroy
} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}}
test oo-nextto-1.3 {basic nextto functionality: constructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	variable result
	constructor {a c} {
	    lappend result ==A== a=$a,c=$c
	}
    }
    oo::class create B {
	superclass root
	variable result
	constructor {b} {
	    lappend result ==B== b=$b
	}
    }
    oo::class create C {
	superclass A B
	variable result
	constructor {p q r} {
	    lappend result ==C== p=$p,q=$q,r=$r
	    # Route arguments to superclasses, in non-trival pattern
	    nextto B $q
	    nextto A $p $r
	}
	method result {} {return $result}
    }
    [C new x y z] result
} -cleanup {
    root destroy
} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z}
test oo-nextto-1.4 {basic nextto functionality: destructors} -setup {
    oo::class create root {destructor return}
} -body {
    oo::class create A {
	superclass root
	destructor {
	    lappend ::result ==A==
	    next
	}
    }
    oo::class create B {
	superclass root
	destructor {
	    lappend ::result ==B==
	    next
	}
    }
    oo::class create C {
	superclass A B
	destructor {
	    lappend ::result ==C==
	    lappend ::result |
	    nextto B
	    lappend ::result |
	    nextto A
	    lappend ::result |
	    next
	}
    }
    set ::result ""
    [C new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==}

test oo-nextto-2.1 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {error $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto A $y}
    }
    [B new] x boom
} -cleanup {
    root destroy
} -result boom -returnCodes error
test oo-nextto-2.2 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {error $y}
    }
    oo::class create B {
	superclass root
	method x y {nextto A $y}
    }
    [B new] x boom
} -returnCodes error -cleanup {
    root destroy
} -result {method has no non-filter implementation by "A"}
test oo-nextto-2.3 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto A $y}
    }
    [B new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {method implementation by "B" not reachable from here}
test oo-nextto-2.4 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto}
    }
    [B new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {wrong # args: should be "nextto class ?arg...?"}
test oo-nextto-2.5 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto $y $y $y}
    }
    [B new] x A
} -cleanup {
    root destroy
} -result {wrong # args: should be "nextto A y"} -returnCodes error
test oo-nextto-2.6 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	method x y {nextto $y $y $y}
    }
    [B new] x [root create notAClass]
} -cleanup {
    root destroy
} -result {"::notAClass" is not a class} -returnCodes error
test oo-nextto-2.7 {errors in nextto} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x y {nextto $y}
    }
    oo::class create B {
	superclass A
	filter Y
	method Y args {next {*}$args}
    }
    oo::class create C {
	superclass B
	method x y {nextto $y $y $y}
    }
    [C new] x B
} -returnCodes error -cleanup {
    root destroy
} -result {method has no non-filter implementation by "B"}

test oo-call-1.1 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    info object call y x
} -cleanup {
    root destroy
} -result {{method x ::A method}}
test oo-call-1.2 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{method x ::B method} {method x ::A method}}
test oo-call-1.3 {object call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    oo::objdefine y method x {} {}
    info object call y x
} -cleanup {
    root destroy
} -result {{method x object method} {method x ::A method}}
test oo-call-1.4 {object object call introspection - unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    A create y
    info object call y z
} -cleanup {
    root destroy
} -result {{unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.5 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    A create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x ::A method}}
test oo-call-1.6 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.7 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.8 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	method z {} {}
	filter z
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
test oo-call-1.9 {object call introspection - filters} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	method z {} {}
	filter z
    }
    B create y
    info object call y y
} -cleanup {
    root destroy
} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}}
test oo-call-1.10 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
	filter y
    }
    oo::class create ::B {
	superclass A
	method y {} {}
	method unknown {} {}
    }
    B create y
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.11 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
	filter y
    }
    A create y
    oo::objdefine y method unknown {} {}
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.12 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
    }
    A create y
    oo::objdefine y {
	method unknown {} {}
	filter y
    }
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-1.13 {object call introspection - filters + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method y {} {}
    }
    A create y
    oo::objdefine y {
	method unknown {} {}
	method x {} {}
	filter y
    }
    info object call y x
} -cleanup {
    root destroy
} -result {{filter y ::A method} {method x object method}}
test oo-call-1.14 {object call introspection - errors} -body {
    info object call
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.15 {object call introspection - errors} -body {
    info object call a
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.16 {object call introspection - errors} -body {
    info object call a b c
} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
test oo-call-1.17 {object call introspection - errors} -body {
    info object call notanobject x
} -returnCodes error -result {notanobject does not refer to an object}
test oo-call-1.18 {object call introspection - memory leaks} -body {
    leaktest {
	info object call oo::object destroy
    }
} -constraints memory -result 0

test oo-call-2.1 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    info class call A x
} -cleanup {
    root destroy
} -result {{method x ::A method}}
test oo-call-2.2 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    list [info class call A x] [info class call B x]
} -cleanup {
    root destroy
} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}}
test oo-call-2.3 {class call introspection} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    oo::class create ::C {
	superclass A
	method x {} {}
    }
    oo::class create ::D {
	superclass C B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}}
test oo-call-2.4 {class call introspection - mixin} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
    }
    oo::class create ::C {
	superclass A
	method x {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
test oo-call-2.5 {class call introspection - mixin + filter} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::C {
	superclass A
	method x {} {}
	method y {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
    }
    info class call D x
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
	method unknown {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	method y {} {}
	filter y
    }
    oo::class create ::C {
	superclass A
	method x {} {}
	method y {} {}
    }
    oo::class create ::D {
	superclass C
	mixin B
	method x {} {}
	method unknown {} {}
    }
    info class call D z
} -cleanup {
    root destroy
} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}}
test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup {
    oo::class create root
} -body {
    oo::class create ::A {
	superclass root
	method x {} {}
    }
    oo::class create ::B {
	superclass A
	method x {} {}
	filter x
    }
    info class call B x
} -cleanup {
    root destroy
} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}}
test oo-call-2.8 {class call introspection - errors} -body {
    info class call
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.9 {class call introspection - errors} -body {
    info class call a
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.10 {class call introspection - errors} -body {
    info class call a b c
} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
test oo-call-2.11 {class call introspection - errors} -body {
    info class call notaclass x
} -returnCodes error -result {notaclass does not refer to an object}
test oo-call-2.11 {class call introspection - errors} -setup {
    oo::class create root
} -body {
    root create notaclass
    info class call notaclass x
} -returnCodes error -cleanup {
    root destroy
} -result {"notaclass" is not a class}
test oo-call-2.13 {class call introspection - memory leaks} -body {
    leaktest {
	info class call oo::class destroy
    }
} -constraints memory -result 0

test oo-call-3.1 {current call introspection} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	method x {} {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	method x {} {lappend ::result [self call];next}
    }
    B create y
    oo::objdefine y method x {} {lappend ::result [self call];next}
    set ::result {}
    y x
} -cleanup {
    root destroy
} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}}
test oo-call-3.2 {current call introspection} -setup {
    oo::class create root
} -constraints memory -body {
    oo::class create A {
	superclass root
	method x {} {self call}
    }
    oo::class create B {
	superclass A
	method x {} {self call;next}
    }
    B create y
    oo::objdefine y method x {} {self call;next}
    leaktest {
	y x
    }
} -cleanup {
    root destroy
} -result 0
test oo-call-3.3 {current call introspection: in constructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	constructor {} {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	constructor {} {lappend ::result [self call]; next}
    }
    set ::result {}
    [B new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}}
test oo-call-3.4 {current call introspection: in destructors} -setup {
    oo::class create root
} -body {
    oo::class create A {
	superclass root
	destructor {lappend ::result [self call]}
    }
    oo::class create B {
	superclass A
	destructor {lappend ::result [self call]; next}
    }
    set ::result {}
    [B new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}

cleanupTests
return

# Local Variables:
# mode: tcl
# End: