#! /usr/bin/tclsh

package require tcltest 2.0

#namespace import -force ::tcltest::*

namespace eval ::tao::objects {}

set started [clock seconds]
set ::tao(thread-handle) taotest
set me [file normalize [info script]]
lappend auto_path [file dirname [file dirname [file dirname [file normalize $me]]]]

source [file join [file dirname [info script]] .. init.tcl]

set start_build [clock seconds]

set ::trigger 0

source [file join [file dirname $me] testclass.tcl]

###
#  Test the basics
###

::tao::new tao.root ::mrbasic


if [catch {::mrbasic cset testvar 1} err] {
    puts "***DIE***"
    puts $err
    puts ***
    puts $::errorInfo
    exit
}

::tcltest::test tobj-method { Test Method Invocation } -result 1 -body { ::mrbasic cset testvar 1 ; ::mrbasic cget testvar }
::tcltest::test tobj-method { Test Value Save Invocation } -result blue -body { ::mrbasic cset testvar blue ; ::mrbasic cget testvar }

::tao::delete ::mrbasic

::tcltest::test tobj-delete { Test Method Deletion } \
    -returnCodes error \
    -body { ::mrbasic cset testvar 1 } \
    -result {invalid command name "::mrbasic"}

###
#  Retest the basics with object_create
###

::tao::object_create ::mrbasic {testvar purple class simple}
###
#  Test isa
###

::tcltest::test tobj-isa { Isa } -result 1 -body { string is true -strict [::mrbasic isa tao.root] }
::tcltest::test tobj-isa { Isa simple } -result 1 -body { string is true -strict [::mrbasic isa simple] }
::tcltest::test tobj-isa { Is not a foo } -result 0 -body { string is true -strict [::mrbasic isa foo] }

::tcltest::test tobj-method { Test Constructor Inputted Data } -result purple -body { ::mrbasic cget testvar }

::tcltest::test tobj-method { Test Method Cset Invocation } -result 1 -body { ::mrbasic cset testvar 1 ; ::mrbasic cget testvar }

::tcltest::test tobj-method { Test Method Cset Dict Invocation } -result 1 -body { ::mrbasic cset {testvar 1} ; ::mrbasic cget testvar }
::tcltest::test tobj-method { Test Value Save Invocation } -result blue -body { ::mrbasic cset testvar blue ; ::mrbasic cget testvar }
::tcltest::test tobj-method { Test Default Static Value } -result DEADBEEF -body { ::mrbasic cget testVar }
::tcltest::test tobj-method { Test Default Volitile } -result DEADBEEF -body { ::mrbasic cget theOtherVar }


::tcltest::test tobj-method { Test Default Static Retention } -result DEADBEEF -body { ::mrbasic cget testVar }

::tcltest::test tobj-method { Test My Invocation } -result {2 + 2 = 5} -body { ::mrbasic myTest }



::tao::object_create ::mrnonbasic {class notsimple}
###
#  Test isa
###


::tcltest::test tobj-isa { Isa } -result 1 -body { string is true -strict [::mrnonbasic isa tao.root] }
::tcltest::test tobj-isa { Isa simple } -result 1 -body { string is true -strict [::mrnonbasic isa simple] }
::tcltest::test tobj-isa { Is not a foo } -result 0 -body { string is true -strict [::mrnonbasic isa foo] }

::tcltest::test tobj-method { Test Constructor Inputted Data (notsimple class) } -result BEEFDEAD -body { ::mrnonbasic cget testVar }

::tcltest::test tobj-stack-call { 
    Test that the object stack is un-nesting properly
} -result mrnonbasic -body {
    ::mrnonbasic simpleCall ::mrbasic
}


::tcltest::test tobj-stack-callback { 
    Test that the object stack is un-nesting properly
} -result mrnonbasic -body {
    ::mrnonbasic notSimpleCall ::mrbasic
}



::tcltest::test tobj-stack-cleanup { 
    Test that the object stack is empty after all methods resolve
} -result 0 -body {
    llength $::tao::ostack
}

::tao::delete ::mrbasic
::tcltest::test tobj-delete { Test Method Deletion } \
    -returnCodes error \
    -body { ::mrbasic cset testvar 1 } \
    -result {invalid command name "::mrbasic"}

::tao::delete ::mrnonbasic
::tcltest::test tobj-delete { Test Method Deletion } \
    -returnCodes error \
    -body { ::mrnonbasic cset testvar 1 } \
    -result {invalid command name "::mrnonbasic"}



global cdx
set cdx -1
set colors {red green black white olive mauve}
proc exercise {class obj} {
    set testhandle exercise-[string trim $class ::]

    ###
    #  Test for internal defaults
    ###

    set result [$obj returnDefault]

    ::tcltest::test $testhandle-returndefault \
	{Test that returnDefault returns the correct value} \
	-result $result \
	-body {::tao::object_eval $obj Hello}
	

    ###
    #  Test that static values are not changed
    ###
    set oldval [$obj cget staticvar]
    ::tcltest::test $testhandle-static-is-static {Test that static variables do not change} \
	-result $oldval -body {
	    $obj noHarmDone TEST
	    $obj cget staticvar
	}
    ###
    #  Test that variable manipulation
    #  functions are working properly
    ###
    foreach {variable} {
	staticvar symbolvar compatvar newvar
    } {
	set string [lindex $::colors [expr int(rand()*[llength $::colors])]]
	::tcltest::test $testhandle-cgetcset \
	  "Test that cset and cget are both modifying and reading the state of the object var $variable" \
	  -result $string \
	  -body {
	      $obj cset [list $variable $string]
		$obj cget $variable
	   } -cleanup {
	       $obj cset [list staticvar hello]
	   }
    }

    set string [lindex $::colors [expr int(rand()*[llength $::colors])]]
    ::tcltest::test $testhandle-staticvar {
	Test that staticvars are updated through cset
    } -result $string -body {
	$obj cset staticvar $string
       return [$obj Hello]
    } -cleanup {
       $obj cset staticvar hello
    }

    ::tcltest::test $testhandle-triggers {
	Test that variable triggers are happening
    } -result NEW -setup {
	set ::trigger 0    
    } -body {
        $obj configure -compatvar NEW
	if { $::trigger == 0 } { 
	    error {Trigger event did not occur}
	}
	$obj cget compatvar
    }

    set string [lindex $::colors [expr int(rand()*[llength $::colors])]]
    #$obj setsym $string
    #set result [$obj getsym]
    if {[lsearch {foo.bar foo.bat fubar} $class] >= 0 } {
	::tcltest::test $testhandle-getsym {
	   Test that getsym is chaining properly
	   Should return the input value with -2 appended
	} -result ${string}-2 -body {
	   $obj setsym $string
	   $obj getsym
	}
    } else {
	::tcltest::test $testhandle-getsym {
	   Test that getsym is chaining properly
	   Should return the input value to setsym
	} -result ${string} -body {
	   $obj setsym $string
	   $obj getsym
	}
    }

    if [$obj isa foo.baz] {
	set okresult Tomato
    } else {
	set okresult TomAto
    }	
    
    ::tcltest::test $testhandle-inheritance {
	Test Inheritance with a simple game
    } -result $okresult -body {$obj YouSay}

    ###
    #  Test chaining
    ###
    set input [expr int(rand() * 100)]
    #set result [$obj increment $input]
    set desired [expr $input * 2]
    if [$obj isa foo.bar] {
	set desired [expr $desired * 3]
    }
    if [$obj isa foo.baz] {
	set desired [expr $desired * 5]
    }
    ::tcltest::test $testhandle-chaining {
	Test than meshing works as advertised
    } -result $desired -body {
	$obj increment $input
    }
    #try $class $obj $desired $result "Meshing not working"
    #try $class $obj $::bark [$obj bark] "Bark doesn't work"
    ::tcltest::test $testhandle-bark {
	test that Bark actually works
    } -result $::bark -body {$obj bark}

}


set start_cbuild [clock seconds]

set obj 0
set testobj {}


foreach class {
	foo
	foo.bar
	foo.bat
} {
    set obj [::tao::new $class #auto string Gravy bark Bites]
    lappend testobj $class $obj
}

::tao::clobject ::fubar {
    inherit foo.bat


} bark BARK string FUBAR 

lappend testobj fubar ::fubar

::tao::clobject ::fubing {
    inherit foo.bing


} bark BARK string FUBAR 


set start_run1 [clock seconds]

set ::bark BARK
foreach {c o} $testobj {
    exercise $c $o
}

set start_rebuild [clock seconds]

set ::bark "THERE IS NO BARK"
::tao::class_modify foo {
    method bark {} { 
	return "THERE IS NO BARK"
    }
}
set start_run2 [clock seconds]

foreach {c o} $testobj {
    exercise $c $o
}
foreach {c o} $testobj {
    ::tao::delete $o
}
set ended [clock seconds]

proc herit_exercise {c classname classlist staticval} {
    
    set obj [::tao::new $classname #auto]

    ::tcltest::test inheritence-$c {
	Test inheritance
    } -result $classname -body { $obj test }


    ::tcltest::test inheritence-chain-$c {
	Test inheritance chaining
    } -result $classlist -body { $obj heritree }

    ::tcltest::test inheritence-static-$c {
	Test inheritance static variable
    } -result $staticval -body { $obj testStatic }

    ::tao::delete $obj
}

set lastclass {}
set clist     {}
foreach c {a b c d e f g} { 
    set classname  herit.${c}
    lappend clist $classname
    herit_exercise $c $classname $clist $classname
    set lastclass $classname

}

herit_exercise foo herit.foo {herit.a herit.b herit.c herit.foo} herit.c


herit_exercise bar herit.bar {herit.a herit.b herit.c herit.foo herit.bar} herit.c

herit_exercise baz herit.baz {herit.a herit.b herit.c herit.d herit.foo herit.bar herit.baz} herit.d