#$Id: s.testx.xotcl 1.15 01/05/16 14:27:49+02:00 neumann@mohegan.wu-wien.ac.at $
proc ::errorCheck {got expected msg} {
  if {$got != $expected} {
    puts stderr "FAILED: $msg\nGot:      $got\nExpected: $expected"
    foreach g [split $got -] e [split $expected -] {
      set result [expr {$g == $e}]
      puts "$result g='$g' e='$e' "
    }
    exit -1
  }
}

proc ::cutSpaces {string} {
  regsub -all "  " $string "" result
  regsub -all "\n" $result " " result
  return $result
}

Class TestX
@ @File {description {
  This is a file which provides a regression test
  for the features of the XOTcl - Language. 
  }
}
@ Class TestX

TestX nestingClasses
@ TestX nestingClasses {
    description {Regression test object testing the class nesting feature.}
}
nestingClasses proc run {{n 50}} {
  for {set i 0} {$i < $n} {incr i} {
    Class x($i)

    Class x($i)::y
    ::errorCheck [x($i) info commands y] "y" \
      "[self] -- creating Nested Class "
    Class x($i)::z
    Class x($i)::z::t
    Class x($i)::t
    ::errorCheck [x($i) info commands t]  "t" \
      "[self] -- MakeClass "
    
    x($i) a
    x($i)::z a
    x($i)::z::t a
    x($i)::z::t move x($i)::z::rt
    x($i)::z::rt a

    ::errorCheck [x($i)::z info commands rt] "rt" \
      "[self] -- renaming leaf "
    
    x($i)::z move x($i)::rz
    ::errorCheck [x($i)::rz info commands rt] "rt" \
      "[self] -- renaming node "
    
    ::errorCheck [x($i) info commands rz] "rz" \
      "[self] -- renaming node "
    
    x($i) move rx 
    ::errorCheck [rx info commands rz] "rz" \
      "[self] -- renaming root "
    ::errorCheck [info commands rx] "rx" \
      "[self] -- renaming root "
    rx destroy
  }
  return "PASSED [self]" 
}

TestX nestingObjects
@ TestX nestingObjects {
    description {Regression test object testing the object nesting feature.}
}

nestingObjects proc run {{n 50}} {
  for {set i 0} {$i < $n} {incr i} {
    Class C($i)
    
    C($i) instproc testinstproc {} {
      return
    }
    C($i) o
    o proc testproc {} {
      return
    }
    o testproc; o testinstproc
    C($i) o::y
    ::errorCheck [o info commands y] "y" \
      "[self] -- creating Nested Object "
    C($i) o::z
    C($i) o::z::t
    C($i) o::t
    ::errorCheck [o info commands t]  "t" \
      "[self] -- MakeObject "
    o::z::t move o::z::rt
    ::errorCheck [o::z info commands rt]  "rt" \
      "[self] -- renaming leaf "
    o::z move o::rz
    ::errorCheck [o::rz info commands rt] "rt" \
      "[self] -- renaming node "
    ::errorCheck [o info commands rz] "rz" \
      "[self] -- renaming node "
    o move rx 
    ::errorCheck [rx info commands rz] "rz" \
      "[self] -- renaming root " 
    ::errorCheck [info commands rx] "rx" \
      "[self] -- renaming root "
    rx destroy
    C($i) destroy
    
    Class A
    A instproc x {a1 args} {
      [self] set var $a1
    }
    A a
    A a::n -x "1 2 3"
    ::errorCheck [::a::n set var] "1 2 3" \
      "[self] -- arg passing - init dash"  
  }
  return "PASSED [self]"
}

TestX assertions
@ TestX assertions {
  description {Regression test object testing the assertions.}
  }

assertions proc run {{n 50}} {
  for {set i 0} {$i < $n} {incr i} {
    Class C($i)
    C($i) invar {
      {$a > 2} {$c < 3} {$d > 5}
      {#a} {#b} 
    }
    C($i) instinvar {
      {$a > 2} {$c < 3} {$d > 5}
      {#a} {#b} 
    }

    ::errorCheck [C($i) info invar]  {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \
      "[self] -- Class invar " 

    ::errorCheck [C($i) info invar]  {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \
      "[self] -- Class instinvar " 
    Object b($i)
    b($i) invar {
      {$a > 2} {$c < 3} {$d > 5}
      {#a} {#b} 
    }
    ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a} {#b}} \
      "[self] -- Object invar " 

    b($i) proc p {a b c} {
      return p
    } {pre1 pre2 pre3} {post1 post2 post3}
    ::errorCheck [b($i) info pre p]  {{pre1} {pre2} {pre3}} \
	"[self] -- Obj proc pre assertion " 
    ::errorCheck [b($i) info post p]  {{post1} {post2} {post3}} \
	"[self] -- Obj proc post assertion " 
    C($i) instproc p {a b c} {
      return p
    } {} {post1 post2 post3}

    ::errorCheck [C($i) info instpre p]  "" \
	"[self] -- CL proc pre assertion " 
    ::errorCheck [C($i) info instpost p] {{post1} {post2} {post3}} \
	"[self] -- CL proc post assertion "

    C(0) set a 3; C(0) set c 2; C(0) set d 7; C(0) set f 50;
    C(0) check all
    C(0) proc checkit {} {
      C(0) instvar a c d f
      ::errorCheck [[self] info check] {invar instinvar pre post} \
	"check options != all"
      # turn obj-invar off
      C(0) check {pre post instinvar}
      C(0) set c 10    
      ::errorCheck [[self] info check] {instinvar pre post} \
	"check options != instinvar pre post"
    } {{$f > 10}} {{$f < 100}}
    C(0) checkit
  }
  for {set i 0} {$i < $n} {incr i} {
    b($i) destroy
    C($i) destroy
  }

  Class Sensor -parameter {{value 1}}
  Sensor instinvar {
   {[regexp {^[0-9]$} [[self] value]] == 1}
  }   
  Sensor s
  s check all

  Sensor instproc x {} {
    s value
  } {
    {[regexp {^[0-9]$} [[self] value]] == 1}
  } {}
  s x
  s value

  # inheritance

  Class A -parameter {{x 1} {y 1}}

  A instinvar {{$x == 1}}
      
  A instproc xTo2 args {
    [self] set x 2
  }
  A instproc yTo2 args {
    [self] set y 2
  } {} {{$y == 1}}
  A a -check all

  if {![catch {a xTo2} err]} {
    set err "ok"
  } else {
    a check {}
    a set x 1
    a check all
  }
  ::errorCheck $err {Error - Assertion failed check: {$x == 1} in proc 'xTo2'} \
    "[self] inheritance a xTo2"

  if {![catch {a yTo2} err]} {
    set err "ok"
  }
  ::errorCheck $err {Error - Assertion failed check: {$y == 1} in proc 'yTo2'} \
    "[self] inheritance a yTo2"

  Class B -superclass A
  B b -check all

  if {![catch {b xTo2} err]} {
    set err "ok"
  } else {
    b check {}
    b set x 1
    b check all
  }
  ::errorCheck $err {Error - Assertion failed check: {$x == 1} in proc 'xTo2'} \
    "[self] inheritance b xTo2"

  if {![catch {b yTo2} err]} {
    set err "ok"
  }
  ::errorCheck $err {Error - Assertion failed check: {$y == 1} in proc 'yTo2'} \
    "[self] inheritance b yTo2"

  return "PASSED [self]"
}

TestX filterAddRemove
@ TestX filterAddRemove {
  description {Regression test object testing adding/removing of filters.}
}

filterAddRemove proc run {{n 50}} {
  set ::filterCount 0
  for {set i 0} {$i < $n} {incr i} {
    Class SA($i)
    Class SB($i) 
    Class SC($i) -superclass [list SB($i) SA($i)]
    SA($i) instproc fa args {
      incr ::filterCount
      [self] set x 150
      return "[next] [self class]::[self proc]"
    }
    SA($i) instproc f2 args {
      incr ::filterCount
      [self] set x 150
      return "[next] [self class]::[self proc]" 
    }
    SB($i) instproc f2 args {	    
      incr ::filterCount
      set [self]::x 150
      return "[next] [self class]::[self proc]" 
    }
    SB($i) instproc fb args {
      incr ::filterCount
      set [self]::x 150
      return "[next] [self class]::[self proc]" 
    }
    SC($i) instproc fc args {
      incr ::filterCount
      set [self]::x 150
      return "[next] [self class]::[self proc]" 
    }
    SC($i) filter fc
    SB($i) filter {fb f2}
    SA($i) filter {fa f2}
    Class T
    T proc s {} { return } 
    Class Filtered${i} -superclass SC($i)
    Filtered${i} instproc filter args {
      incr ::filterCount
      T s
      return "[next] [self proc]"  
    }
    Filtered${i} filter filter
    Filtered${i} instproc a {} {
      return in-a
    }
    Filtered${i} f${i}
    set erg [f${i} a]   
    ::errorCheck $erg \
      "in-a ::SA(${i})::f2 ::SA(${i})::fa ::SA(${i})::f2 ::SB(${i})::f2 ::SB(${i})::fb ::SC(${i})::fc filter" \
      "[self] -- Filter Test - add"
    SC($i) filter {}
    SB($i) filter fb
    SA($i) filter {}
    set erg [f${i} a]
    ::errorCheck $erg "in-a ::SB($i)::fb filter" \
      "[self] -- Filter Test - remove"	    
  }
  for {set i 0} {$i < $n} {incr i} {
    SA($i) destroy
    SB($i) destroy
    SC($i) destroy
  }
    
  ::errorCheck $::filterCount 1900 \
    "[self] -- Filter Test  - Filter Count -- Got: $::filterCount"
  
  #
  # instvar test
  #
  global filterResult
  set filterResult ""
  Object a
  a set o 12
  a set p 13
  Class A
  A set m 14
  
  Object instproc f args {
    global filterResult
    a instvar o p
    A instvar m
    ::append filterResult " [self] [self calledproc] [self callingproc]"
    ::append filterResult " $o $p $m"
    
    next
  }
  
  proc x {} {
    set ::a::e xxx
  }
  
  Object filter f
  x

  ::errorCheck $::a::e xxx \
    "filterAddRemove: instvar test -- proc set failed"
  a set e yyy
  ::errorCheck $::a::e yyy \
    "filterAddRemove: instvar test -- obj set failed"
  
  ::errorCheck $filterResult " ::A instvar f 12 13 14 ::a set run 12 13 14" \
    "filterAddRemove: instvar test -- instvar filter failed"
  
  Object filter ""   

  return "PASSED [self]"	
}

TestX filterClassChange 
@ TestX filterClassChange {
    description {Regression test object testing class changes of filters.}
}

filterClassChange proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {
	Class A($i)
	Class B

	A($i) instproc f args {
	    set result pre*[self]*[self proc]*$args
	    lappend result [next] post*[self]*[self proc]
	    return $result
	}
	
	A($i) o($i)	
	o($i) proc change {} {
	    [self] class B
	}
	o($i) proc call {} {
	    return in-call
	} 
	
	A($i) filter f
	
	set erg [o($i) call]
        ::errorCheck $erg "pre*::o($i)*f* in-call post*::o($i)*f" \
	    "[self] -- Filter Class Change -- Call before change"	
	o($i) change
	set erg [o($i) call]
	::errorCheck $erg "in-call" \
	    "[self] -- Filter Class Change -- Call after change"
    }
    B destroy
    for {set i 0} {$i < $n} {incr i} {A($i) destroy}
    return "PASSED [self]"
}

TestX filterSimpleObserver
@ TestX filterSimpleObserver {
    description {Regression test object testing a simple observer using filters.}
}

filterSimpleObserver proc run {{n 50}} {
    set ::filterCount 0
    for {set i 0} {$i < $n} {incr i} {
	Class NetAccess$i
	Class Http$i -superclass NetAccess$i
	Class TransferDialog$i

	TransferDialog$i proc addObserver cl {
	    $cl instproc observerFilter args {
		set calledMethod [self calledproc]
		set callingClass [[self] info class]
		incr ::filterCount
		set result [next]
		
		[self] set r 34
		
		foreach var {args calledMethod callingClass result} {
		    if {[info vars $var] != $var} {
			puts stderr "[self] -- Simple Observer - info vars in filter"
			exit
		    }
		}
	    

	    return [self]-[self class]-[[self] info class]-$args-[self calledproc]-[self callingproc]-$result
	    }
	    $cl filter observerFilter
	}

	TransferDialog$i instproc show {i} {
	    next
	    TransferDialog${i} addObserver NetAccess$i
	    [self class] instvar observingObjects
	    lappend observingObjects(::NetAccess$i) [self]
	}

	Http$i parameter {a be bu}
	Http$i instproc path x    { [self] set path $x }

	Http$i instproc query x   { 
	    [self] set [self proc] $x 
	}
	Http$i instproc init {args} { 
	    [self] set url abc
	    next
	    [self] instvar query path bu
	    if {![info exists query] || 
		![info exists path] || 
		![info exists bu] || 
		$query != "q"} { 
		puts stderr "FAILED - [self] -- Simple Observer - Variable Init"; exit
	    }
	}

  	Http$i instproc GET {x} {
	    [self] instvar query url path
	    if {[info exists query]} {
		append url ?$query
		append path ?$query
	    }
	set ::baseLevel [info level]


	if {0 != [expr [info level] - $::baseLevel]} {
		puts stderr "FAILED - [self] -- Simple Observer - info level in filtered proc\n\
                 expected 0, got [expr [info level] - $::baseLevel]"
		exit
	    }
	    foreach var {x path query url} {
		if {[info vars $var] != $var} {
		puts stderr "FAILED - [self] -- Simple Observer - info vars in filtered proc"; 
		    exit
		}
	    }
	    return $url
	}
	
	TransferDialog$i t($i)
	t($i) show $i

	Http$i h($i) -query q -path p -bu b

	set erg [h($i) GET 1]
	::errorCheck $erg "::h($i)-::NetAccess$i-::Http$i-1-GET-run-abc?q" \
	    "[self] -- Simple Observer - Filter Return"
	
    }
    for {set i 0} {$i < $n} {incr i} {
	NetAccess$i filter {}
		
	h($i) destroy  
	t($i) destroy
	
	Http$i  destroy
	NetAccess$i destroy
	TransferDialog$i destroy
    }

    ::errorCheck  $::filterCount 550 \
	"[self] -- Simple Observer - Filter Count" 
    
    return "PASSED [self]"   
}

TestX stdargs
@ TestX stdargs {
    description {
	Regression test object testing the ability of the next primitive to pass
	arguments without naming them.
    }
}

stdargs proc run {{n 50}} {
  for {set i 0} {$i < $n} {incr i} {
    Class C
    Class D
    Class A -superclass {C D}
    Class B -superclass A
    
    C instproc t {} {
      next
      return
    }
    D instproc t args {
      ::errorCheck $args "" \
	"[self] -- --noArgs"
      next
      return
    }
    
    A instproc t {a b args} {
      if {$a != 1 || $b != 2 || $args != {3 4 5 6 7 8 9}} {
	puts stderr "FAILED - [self] -- StdArgs not computed"; exit
      }	
      next --noArgs
      return 
    }
    
    B instproc t {a b args} {
      if {$a != 1 || $b != 2 || $args != {3 4 5 6 7 8 9}} {
	puts stderr "FAILED -[self] -- StdArgs not computed"; exit
      }		
      next 
      return
    }

    B x
    x t 1 2 3 4 5 6 7 8 9
  }
  foreach o {x A B C D} {$o destroy}
  return "PASSED [self]"
}



TestX filterInfo
@ TestX filterInfo {
    description{
	Regression test object testing introspection of filters.
    }
}
# Helper Procs

proc ::showStack {{m 100}} {
    set r ""
    set max [info level]  
    if {$m<$max} {set max $m}
    for {set i 0} {$i < $max} {incr i} {
	set r ${r}-$i=[info level [expr -$i]]
    }
    return $r
}
proc ::showCall {} {
    set n ""
    for {set level -1} {1} {incr level -1} {
	set p [info level $level]
	if {[lindex $p 0] == "next"} {set n "next:"} break
    }
    return [showStack]
}

filterInfo proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {
	global FInfo
	set FInfo ""
	
	Class FI

	FI proc addFilter {classname} {
	    $classname 	instproc infoFilter args {
	      global FInfo
	      set FInfo "$FInfo [self callingclass]"
	      set FInfo "$FInfo [self regclass]"
	      set FInfo "$FInfo [self callingobject]"
	      set FInfo "$FInfo [self callingproc]"
	      set FInfo "$FInfo [self calledproc]"
	      set r [next]
	      set FInfo "$FInfo [self]-[self proc]-[self class]-[[self] info class]-$r"
	      return $r
	    }
	    $classname filter infoFilter
	}

	Class C0
	FI addFilter C0
	C0 instproc m1 {} {
	    [self] instvar aa bb cc
	    set cc 1
	}
	
	Class C1 -superclass C0
	C1 instproc init args {
	    [self] set a 1
	    [self] set c 22
	    next
	}
	C1 instproc m1 args {
	    set r [next]
	    [self] instvar a b cc
	    return $r--${a}--[set cc]
	}

	set safedObjFilters [Object info filter]
	Object filter "" 
	C1 c1
	Object filter $safedObjFilters

      if {$i == 0} {
	::errorCheck "$FInfo" \
	    "  ::C0 ::filterInfo run configure ::c1-infoFilter-::C0-::C1-  ::C0 ::filterInfo run init ::C1 ::C0 ::c1 init set ::c1-infoFilter-::C0-::C1-1 ::C1 ::C0 ::c1 init set ::c1-infoFilter-::C0-::C1-22 ::c1-infoFilter-::C0-::C1-" \
	    "Wrong filtering of instproc creation C/C1"
      } else {
	::errorCheck "$FInfo" \
	    "  ::C0 ::filterInfo run cleanup ::c1-infoFilter-::C0-::C1-  ::C0 ::filterInfo run configure ::c1-infoFilter-::C0-::C1-  ::C0 ::filterInfo run init ::C1 ::C0 ::c1 init set ::c1-infoFilter-::C0-::C1-1 ::C1 ::C0 ::c1 init set ::c1-infoFilter-::C0-::C1-22 ::c1-infoFilter-::C0-::C1-" \
	    "Wrong filtering of instproc creation C/C1 (b)"
      }

	set FInfo ""
	set result [c1 m1]
	
	::errorCheck "$FInfo" \
	    "  ::C0 ::filterInfo run m1 ::C0 ::C0 ::c1 m1 instvar ::c1-infoFilter-::C0-::C1- ::C1 ::C0 ::c1 m1 instvar ::c1-infoFilter-::C0-::C1- ::c1-infoFilter-::C0-::C1-1--1--1" \
	    "Wrong filtering of c1 m1"

	set FInfo ""

	::errorCheck "$result" \
	  "1--1--1" "Wrong return result of Filter Example 2 'c1 m1' "

	
	Class T0
	FI addFilter T0
	T0 instproc m {} {
	    if {[string first "-0=showStack-1=showCall-2=m-3=m-4=run-5=run" [showCall]] == -1} {    
		puts stderr "FAILED - Wrong calling stack in T0 m: [showCall]"
		exit
	    }
	    return [self]-[self proc]-[self class]-[[self] info class] 
	}	
	Class T1 -superclass T0
	T1 instproc m {} {
	    if {[string first "-0=showStack-1=showCall-2=m-3=run-4=run" [showCall]] == -1} {
		puts stderr "FAILED - Wrong calling stack in T1 m: [showCall]"
		exit
	    }	  
	   
            set r1 before-[self]-[self proc]-[self class]-[[self] info class] 
            set r2 [next]
	    set r after-[self]-[self proc]-[self class]-[[self] info class]-${r1}-$r2
	}
	
	T1 t

	set FInfo ""
	set result [t m]
	::errorCheck "$FInfo" \
	    "  ::T0 ::filterInfo run m ::T1 ::T0 ::t m info ::t-infoFilter-::T0-::T1-::T1 ::T0 ::T0 ::t m info ::t-infoFilter-::T0-::T1-::T1 ::T1 ::T0 ::t m info ::t-infoFilter-::T0-::T1-::T1 ::t-infoFilter-::T0-::T1-after-::t-m-::T1-::T1-before-::t-m-::T1-::T1-::t-m-::T0-::T1" \
	    "Wrong filtering of t m"

	set FInfo ""	
	::errorCheck "$result" \
	    "after-::t-m-::T1-::T1-before-::t-m-::T1-::T1-::t-m-::T0-::T1" \
	    "Wrong return result of Filter Example 2 \"t m\" "
    }
    c1 destroy

    for {set i 0} {$i < $n} {incr i} {
      global InfoTraceResult

      Object InfoTrace
      InfoTrace proc createInfoTrace cl {
	$cl instproc infoTraceFilter args {
	  global InfoTraceResult
	  ::set r [next]
	  ::append InfoTraceResult ${r}-[self]-[self proc]-[self class]
	  ::append InfoTraceResult -[[self] info class]-[self calledproc]
	  ::append InfoTraceResult -[self callingproc]-[self callingobject]
	  ::append InfoTraceResult -[self callingclass]-[self regclass]
	  return $r
	}
	$cl filter infoTraceFilter
      }        
      Class ObjectsClass       
      ObjectsClass anObject
      Class aClass
      ObjectsClass instproc aProc {} {aClass create anotherObject}
      InfoTrace createInfoTrace Object
      set InfoTraceResult ""
      set r [anObject aProc]
      if {$i > 0} {
      ::errorCheck $InfoTraceResult \
	"-::anotherObject-infoTraceFilter-::Object-::aClass-class-infoTraceFilter-::aClass-::Object-::Object-::anotherObject-infoTraceFilter-::Object-::aClass-cleanup-infoTraceFilter-::aClass-::Object-::Object-::Class::Parameter-infoTraceFilter-::Object-::Class-searchDefaults-infoTraceFilter-::aClass-::Object-::Object-::anotherObject-infoTraceFilter-::Object-::aClass-configure-infoTraceFilter-::aClass-::Object-::Object-::anotherObject-infoTraceFilter-::Object-::aClass-init-infoTraceFilter-::aClass-::Object-::ObjectanotherObject-::aClass-infoTraceFilter-::Object-::Class-recreate-infoTraceFilter-::aClass-::Object-::Object::anotherObject-::aClass-infoTraceFilter-::Object-::Class-create-aProc-::anObject-::ObjectsClass-::Object::anotherObject-::anObject-infoTraceFilter-::Object-::ObjectsClass-aProc-run-::filterInfo--::Object" \
	"FilterInfo InfoTrace: Filter information wrong (b)"
      } else {
	::errorCheck $InfoTraceResult \
	  "-::aClass-infoTraceFilter-::Object-::Class-alloc-infoTraceFilter-::aClass-::Object-::Object-::Class::Parameter-infoTraceFilter-::Object-::Class-searchDefaults-infoTraceFilter-::aClass-::Object-::Object-::anotherObject-infoTraceFilter-::Object-::aClass-configure-infoTraceFilter-::aClass-::Object-::Object-::anotherObject-infoTraceFilter-::Object-::aClass-init-infoTraceFilter-::aClass-::Object-::Object::anotherObject-::aClass-infoTraceFilter-::Object-::Class-create-aProc-::anObject-::ObjectsClass-::Object::anotherObject-::anObject-infoTraceFilter-::Object-::ObjectsClass-aProc-run-::filterInfo--::Object" \
	  "FilterInfo InfoTrace: Filter information wrong"
      }
      Object filter {}
    }

	      
    return "PASSED [self]"
}

TestX nextTest
@ TestX nextTest {
    description {
	Regression test object testing the next primitive.
    }
}
nextTest proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {
	
	global result infoNext
	set result ""
	set infoNext ""

	Class X
	X instproc n {} {
	  append ::infoNext " [self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	Class Y -superclass X
	Y instproc m {} {
	  append ::infoNext " [self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	Y instproc n {} {
	  append ::infoNext " [self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	Y y
	
	y m
	y n
	y proc n {} {
	  append ::infoNext " [self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	y n
	::errorCheck $infoNext " ::y+::Y->m*<> ::y+::Y->n*<::XOTclClasses::X::n> ::y+::X->n*<> ::y+->n*<::XOTclClasses::Y::n> ::y+::Y->n*<::XOTclClasses::X::n> ::y+::X->n*<>" \
	  "simple self next test"
	set infoNext ""
	set result ""

	Class A
	A instproc m arg {
	  global result infoNext
	  set result ${result}-[self]-$arg
	}
	Class B -superclass A
	B instproc m arg {
	  global result infoNext
	  set result ${result}-[self]-$arg
	  append infoNext " 2[self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	B b0 -m 1 
	B b -m "" 
	
	::errorCheck $result "-::b0-1-::b0-1-::b--::b-" \
	    "Next Test A/B -- Wrong result"
	
	set result ""

	Class X
	X instproc init args {
	  global result infoNext
	  set result ${result}-[self]-$args
	  append infoNext " 1[self]+[self class]->[self proc]*<[self next]>"
	  next
	}
	X instproc test {} {
	    global result 
	    set result ${result}-[self]
	}

	X x -test 
	::errorCheck $result "-::x-::x-" \
	    "Next Test X -- Wrong result"
	::errorCheck $infoNext " 2::b0+::B->m*<::XOTclClasses::A::m> 2::b+::B->m*<::XOTclClasses::A::m> 1::x+::X->init*<::XOTclClasses::Object::init>" \
	    "self next test 2"
	X destroy
	x destroy
	A destroy
	B destroy
	b0 destroy
	b destroy
    }
    return "PASSED [self]"
}

TestX init_params
@ TestX init_params {
    description {
	Regression test object testing the parameter instance method, 
	the init dash '-' and constructor calling.
    }
}

init_params proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {

	global dashResult
	set dashResult ""
	set dashResultEnd ""
	Class A
	A instproc t0 {} {
	  global dashResult 
	  set dashResult ${dashResult}*[self proc]
	}
	A instproc t1 {a} {
	  global dashResult 
	  set dashResult ${dashResult}*[self proc]-$a
	}
	A instproc t2 {a b} {
	  global dashResult 
	  set dashResult ${dashResult}*[self proc]-${a}-$b
	}
	A instproc t3 {a b c} {
	  global dashResult 
	  set dashResult ${dashResult}*[self proc]-${a}-${b}-$c
	}
	A a
	set dashResultEnd "[A a -t0] $dashResultEnd"

	A a
	set dashResultEnd  "[A a -t1 1] $dashResultEnd"
	A a
	set dashResultEnd "[A a -t2 1 2] $dashResultEnd"
	A a
	set dashResultEnd "[A a -t3 1 2 3] $dashResultEnd"
	A a
	set dashResultEnd "[A a -t0 -t0 -t3 1 2 3 -t0 -t1 1 -t1 1 -t0] $dashResultEnd"

   
	catch {A a t}

	::errorCheck $dashResult \
	    "*t0*t1-1*t2-1-2*t3-1-2-3*t0*t0*t3-1-2-3*t0*t1-1*t1-1*t0" \
	    "Init Dash Test fails"
	::errorCheck $dashResultEnd \
	    "::a ::a ::a ::a ::a " \
	    "Init Dash Test fails -- result"
    }

    # paramter/defaults test

    proc ::cmd {a b} {
	return in-cmd-${a}-${b}
    }

    global parameterResult
    global initResult

    for {set i 0} {$i < $n} {incr i} {
	Class O -parameter {
	    {a -default 0} 
	    {b -default {[cmd 3 4]}} c d 
	    {e -default 3} 
	    {Self -default [self]}
	}	

	O instproc init args {
	    global initResult 
	    set initResult ${initResult}-[self]-[self class]-[self proc]--$args
	    next
	}
	O instproc show {} {
	    global parameterResult 
	    set parameterResult [self]
	    foreach v [lsort [[self] info vars]] {
		set parameterResult ${parameterResult}-${v}=<[set [self]::${v}]>
	    }
	}	
	Class Meta -superclass Class
	Meta instproc create args {next; return Meta-create}
	Meta C -superclass O -parameter {a {b -default ""} {c -default 1}}
	Class D -parameter {a {c -default 1}} -superclass O
	# create on class should not be called
	D instproc create args {next; return D-create}

	D instproc init args {
	    global initResult
	    set initResult ${initResult}-[self]-[self class]-[self proc]--$args
	    next
	}

	D instproc test i {
	  ::errorCheck [[self] set c]-[[self] set a] "2-0" "Wrong order of init call"
	}
	set parameterResult ""
	set initResult ""
	C c0 -show
      
	::errorCheck $parameterResult "::c0-Self=<::c0>-a=<0>-b=<>-c=<1>-e=<3>" \
	    "C c0 parameter Test failed"
      if {$i == 0} {
	::errorCheck $initResult "-::c0-::O-init--" \
	    "C c0 parameter init Test failed"
      } else {
	::errorCheck $initResult "-::c0-::O-init--" \
	    "C c0 parameter init Test failed (b)"
      }

	set parameterResult ""
	set initResult ""
	set r [C c1 -c 2 -init a b c -a 1 -show]

      ::errorCheck $parameterResult "::c1-Self=<::c1>-a=<1>-b=<>-c=<2>-e=<3>" \
	  "C c1 parameter Test failed (b)"
      
	::errorCheck $initResult "-::c1-::O-init--a b c" \
	    "C c1 parameter init Test failed"

	set parameterResult ""
	set initResult ""
	set r $r-[D d1 -c 2 -init a b c -test $i -a 1 -show]
	::errorCheck $parameterResult "::d1-Self=<::d1>-a=<1>-b=<in-cmd-3-4>-c=<2>-e=<3>" \
	    "D d1 parameter Test failed"
      if {$i == 0} {
	::errorCheck $initResult "-::d1-::D-init--a b c-::d1-::O-init--a b c" \
	    "D d1 parameter init Test failed"
      } else {
	::errorCheck $initResult "-::d1-::D-init--a b c-::d1-::O-init--a b c" \
	    "D d1 parameter init Test failed (b)"
      }


	::errorCheck $r  "Meta-create-::d1" \
	    "User defined object creation failed"
    }
    return "PASSED [self]"
}

TestX mixinTest
@ TestX mixinTest {
    description {
	Regression test object testing per-object mixins.
    }
}

mixinTest proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {
	global mixinResult
	set mixinResult "" 
	Class Agent
	Agent instproc moveAgent {x y} {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	}
	Agent instproc otherProc {} {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	} 
	Class InteractiveAgent -superclass Agent
	InteractiveAgent instproc moveAgent {x y} {
	    global mixinResult	    
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	}
        Class InteractiveAgent2 -superclass Agent
	InteractiveAgent2 instproc moveAgent {x y} {
	    global mixinResult	    
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	}        
        Class InteractiveAgent3 -superclass Agent
	InteractiveAgent3 instproc moveAgent {x y} {
	    global mixinResult	    
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	}
      
	# Addition-Classes
	Class MovementLog  
	MovementLog instproc moveAgent {x y} {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    [self] otherProc
	    next
	}
	MovementLog instproc otherProc {} {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class] 
	    next
	}	
	Class MovementTest
	MovementTest instproc moveAgent {x y} {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class] 
	    next
	}
	InteractiveAgent i1; InteractiveAgent i2
	i1 mixin MovementLog
	i2 mixin MovementTest
	
        InteractiveAgent2 instmixin {MovementLog MovementTest}
        InteractiveAgent3 instmixin MovementTest
        InteractiveAgent2 i3; InteractiveAgent3 i4;

	i2 moveAgent 1 2
	::errorCheck "$mixinResult" \
	    "-::i2-moveAgent-::MovementTest-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \
	    "Mixin: 'i2 moveAgent 1 2' failed"
	
	set mixinResult ""
	i1 moveAgent 3 4
	::errorCheck "$mixinResult" \
	    "-::i1-moveAgent-::MovementLog-::i1-otherProc-::MovementLog-::i1-otherProc-::Agent-::i1-moveAgent-::InteractiveAgent-::i1-moveAgent-::Agent" \
	    "Mixin: 'i1 moveAgent 3 4' failed"

	set mixinResult ""
	i3 moveAgent 3 4
	::errorCheck "$mixinResult" \
	    "-::i3-moveAgent-::MovementLog-::i3-otherProc-::MovementLog-::i3-otherProc-::Agent-::i3-moveAgent-::MovementTest-::i3-moveAgent-::InteractiveAgent2-::i3-moveAgent-::Agent" \
	    "Instmixin: 'i3 moveAgent 3 4' failed"	

        set mixinResult ""
	i4 moveAgent 3 4
	::errorCheck "$mixinResult" \
	    "-::i4-moveAgent-::MovementTest-::i4-moveAgent-::InteractiveAgent3-::i4-moveAgent-::Agent" \
	    "Instmixin: 'i4 moveAgent 3 4' failed"

        i4 mixin {MovementTest MovementLog}

        set mixinResult ""
	i4 moveAgent 5 6
	::errorCheck "$mixinResult" \
	    -::i4-moveAgent-::MovementLog-::i4-otherProc-::MovementLog-::i4-otherProc-::Agent-::i4-moveAgent-::MovementTest-::i4-moveAgent-::InteractiveAgent3-::i4-moveAgent-::Agent \
	    "Instmixin: 'i4 moveAgent 5 6' failed"

	Class A
	A instproc test {} {
	    global mixinResult
	    set mixinResult "test"
	    i1 moveAgent 3 4
	}
	A a
	a test
	::errorCheck "$mixinResult" \
	    "test-::i1-moveAgent-::MovementLog-::i1-otherProc-::MovementLog-::i1-otherProc-::Agent-::i1-moveAgent-::InteractiveAgent-::i1-moveAgent-::Agent" \
	    "Mixin: 'a test' failed"

	i2 mixin {MovementLog MovementTest}

	set mixinResult ""

	i2 moveAgent a b
	::errorCheck "$mixinResult" \
	"-::i2-moveAgent-::MovementLog-::i2-otherProc-::MovementLog-::i2-otherProc-::Agent-::i2-moveAgent-::MovementTest-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \
	    "Mixin: 'i2 moveAgent a b' failed"


	::errorCheck "[i2 info mixin]-[i1 info mixin]-[a info mixin]" \
	"::MovementLog ::MovementTest-::MovementLog-" \
	    "Mixin: Info failed"


	set mixinResult ""
	i2 mixin ""
	i2 moveAgent a b

	::errorCheck "$mixinResult" \
	    "-::i2-moveAgent-::InteractiveAgent-::i2-moveAgent-::Agent" \
	    "Mixin: remove failed"


	set mixinResult ""
	Class A
	A instproc destroy args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class] 
	    next
	}
	A instproc y args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class] 
	    next
	}
	Class B 
	B instproc destroy args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    next
	}
	B instproc y args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class] 
	    [self] mixin ""
	    next
	}
	B instproc x args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    [self] destroy
	}

	A a -mixin B
	a destroy

	A a -mixin B
	a x
	
	A a -mixin B
	a y

	::errorCheck "$mixinResult" \
	"-::a-destroy-::B-::a-destroy-::A-::a-x-::B-::a-destroy-::B-::a-destroy-::A-::a-y-::B-::a-y-::A" \
	    "Mixin: destroy failed"

        A instmixin B
	set mixinResult ""
        A a2
	a2 destroy
        A a2
        a2 x
        A a2
        a2 y

	::errorCheck "$mixinResult" \
	"-::a2-destroy-::B-::a2-destroy-::A-::a2-x-::B-::a2-destroy-::B-::a2-destroy-::A-::a2-y-::B-::a2-y-::A" \
	    "Instmixin: destroy failed"

	# mixin Test: calls the mixins and a proc of the object
	set ::mixinResult ""
	Class A
	Class B
	A instproc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc];next}
	B instproc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc]; next}
	A d -mixin B
	d proc a {} {set ::mixinResult ${::mixinResult}-[self]-[self class]-[self proc]; next}
	d a
	::errorCheck $::mixinResult \
	    "-::d-::B-a-::d--a-::d-::A-a" \
	    "Mixin: calling of object's proc"

	set mixinResult ""

        d mixin {}
        A instmixin B
        d a	

      ::errorCheck $::mixinResult \
	  "-::d-::B-a-::d--a-::d-::A-a" \
	  "Instmixin: calling of object's proc"

	set mixinResult ""

	Class Computation
	Computation instproc compute args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    # abstract interface for computations
	} 
	Class ComputationOutput -superclass Computation
	Computation instproc compute args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    return $args
	} 
	
	Class RecFacultyMixin 
	RecFacultyMixin instproc compute args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    set n [lindex $args 0]
	    set callingClass -
	    catch {set callingClass [uplevel 1 self class]}
	    if {$n == 0} {
		set result 1
	    } else {
		set f [[self] compute [expr $n - 1] x] 
		set result [expr $n * $f] 
	    }
	    if {$callingClass != [self class]} {
		next $result
	    } else {
		return $result
	    }
	}

	ComputationOutput faculty
	faculty mixin RecFacultyMixin 

	::errorCheck [faculty compute 3] 6 \
	    "Mixin: faculty wrong result"

	::errorCheck "$mixinResult" \
	    "-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::Computation" \
	    "Mixin: faculty failed"
	set mixinResult ""

        ComputationOutput faculty
	ComputationOutput instmixin RecFacultyMixin 
	::errorCheck [faculty compute 3] 6 \
	    "Mixin: faculty wrong result"

	::errorCheck "$mixinResult" \
	    "-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::RecFacultyMixin-::faculty-compute-::Computation" \
	    "Mixin: faculty failed"

	set mixinResult ""
	global calling 
	set calling ""
	Class Image
	Image instproc draw args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    global calling
	    set calling "$calling [self callingobject]  [self callingclass]  [self callingproc]"
	}

	Class MenuDecorator 
	MenuDecorator instproc draw args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    global calling
	    set calling "$calling [self callingobject]  [self callingclass]  [self callingproc]"
	    next
	}

	Class ScrollBarDecorator 
	ScrollBarDecorator instproc draw  args {
	    global mixinResult
	    set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
	    global calling
	    set calling "$calling [self callingobject]  [self callingclass]  [self callingproc]"
	    next
	}

	Image mainImage -mixin {MenuDecorator ScrollBarDecorator}
	Image zoom -mixin {ScrollBarDecorator}

	Object instproc f args {
	    if {[self calledproc] != "filter"} {
		global mixinResult
		::set mixinResult ${mixinResult}-[self]-[self proc]-[self class]
		global calling
		::set calling "$calling [self callingobject]  [self callingclass]  [self callingproc]"
	    }
	    next 
	}
	Object filter f

	mainImage draw
	zoom draw

	Object filter ""

	::errorCheck $calling \
	    " ::mixinTest    run ::mixinTest    run ::mainImage  ::MenuDecorator  draw ::mainImage  ::ScrollBarDecorator  draw ::mixinTest    run ::mixinTest    run ::zoom  ::ScrollBarDecorator  draw" \
	    "Mixin: Calling-Obj/Cl/Proc failed"	

      ::errorCheck "$mixinResult" \
	    "-::mainImage-f-::Object-::mainImage-draw-::MenuDecorator-::mainImage-draw-::ScrollBarDecorator-::mainImage-draw-::Image-::zoom-f-::Object-::zoom-draw-::ScrollBarDecorator-::zoom-draw-::Image" \
	"Mixin: Filter failed"	


	set calling ""
	set mixinResult ""

        Image mainImage
        Image zoom
        Image instmixin {MenuDecorator ScrollBarDecorator}

	Object filter f
	mainImage draw
	Object filter ""

        Image instmixin ScrollBarDecorator
	Object filter f
	zoom draw
	Object filter ""

        ::errorCheck $calling \
	    " ::mixinTest    run ::mixinTest    run ::mainImage  ::MenuDecorator  draw ::mainImage  ::ScrollBarDecorator  draw ::mixinTest    run ::mixinTest    run ::zoom  ::ScrollBarDecorator  draw" \
	    "Instmixin: Calling-Obj/Cl/Proc failed"

	::errorCheck "$mixinResult" \
	    "-::mainImage-f-::Object-::mainImage-draw-::MenuDecorator-::mainImage-draw-::ScrollBarDecorator-::mainImage-draw-::Image-::zoom-f-::Object-::zoom-draw-::ScrollBarDecorator-::zoom-draw-::Image" \
	"Instmixin: Filter failed"

    }

    return "PASSED [self]"
}

TestX mixinInheritanceTest
@ TestX mixinInheritanceTest {
    description {
	Regression test object testing per-object mixin inheritance.
    }
}

mixinInheritanceTest proc run {{n 50}} {
    for {set i 0} {$i < $n} {incr i} {
	global mixinResult
	set mixinResult ""
	
	Class A
	Class B
	Class C -superclass {A B}

	Class GeneralMixin
	Class RefinedMixin1 -superclass GeneralMixin
	Class RefinedMixin2 -superclass GeneralMixin
	Class AppMixin1 -superclass {RefinedMixin1 RefinedMixin2}
	Class AppMixin2 -superclass {RefinedMixin2 RefinedMixin1}
	Class AppMixin3 -superclass {RefinedMixin1}

	A instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return $args
	}
	B instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return $args
	}
	C instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next "$args [self class]"]
	}
	GeneralMixin instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next "$args [self class]"]
	}
	RefinedMixin1 instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next "$args [self class]"]
	}
	RefinedMixin2 instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next "$args [self class]"]
	}
	AppMixin1 instproc aProc args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next "$args [self class]"]
	}

	AppMixin1 mixinInstance
	set r [mixinInstance aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin" \
	    "Mixin inheritance: mixinInstance aProc"
	set mixinResult ""

	AppMixin3 mixinInstance2
	set r [mixinInstance2 aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::RefinedMixin1 ::GeneralMixin" \
	    "Mixin inheritance: mixinInstance2 aProc"
	set mixinResult ""

	A a
	a mixin AppMixin1
	set r [a aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::A"  \
	    "Mixin inheritance: a aProc"


	::errorCheck  $r \
	    "{{{{ARGS1 ARGS2 ::AppMixin1} ::RefinedMixin1} ::RefinedMixin2} ::GeneralMixin}" \
	    "Mixin inheritance result: a aProc"

        A a
 	A instmixin AppMixin1

	set mixinResult ""

	set r [a aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::A"  \
	    "Instmixin inheritance: a aProc"
	::errorCheck  $r \
	    "{{{{ARGS1 ARGS2 ::AppMixin1} ::RefinedMixin1} ::RefinedMixin2} ::GeneralMixin}" \
	    "Instmixin inheritance: a aProc"
	set mixinResult ""

	C c
	c mixin {AppMixin3 AppMixin2}

	set r [c aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::AppMixin1 ::RefinedMixin1 ::RefinedMixin2 ::GeneralMixin ::C ::A"  \
	    "Mixin/Instmixin inheritance: c aProc"
        set mixinResult ""
        A instmixin {}

        set r [c aProc ARGS1 ARGS2]
	::errorCheck $mixinResult \
	    " ::RefinedMixin2 ::RefinedMixin1 ::GeneralMixin ::C ::A" \
	    "Mixin/Instmixin inheritance: c aProc"

	GeneralMixin instproc set args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next]
	}
	RefinedMixin1 instproc set args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next]
	}
	AppMixin1 instproc set args {
	    global mixinResult; 
	    ::set mixinResult "$mixinResult [self class]"
	    return [next]
	}

	global setFilterResult 
	set  setFilterResult ""
	Object instproc setFilter args {
	    global setFilterResult
	    ::append setFilterResult \
		-[self calledproc]-[self calledclass]-[self calledclass]
	    next
	}

	Object filter setFilter

	set mixinResult ""
	set r [c set setVar 111]

	::errorCheck $mixinResult \
	    " ::RefinedMixin1 ::GeneralMixin"  \
	    "Mixin inheritance: c set"
	::errorCheck ${c::setVar} 111 "Mixin inheritance: c set - value"

	set mixinResult ""        
	mixinInstance set setVar 222

	::errorCheck $mixinResult \
	    " ::AppMixin1 ::RefinedMixin1 ::GeneralMixin"  \
	    "Mixin inheritance: mixinInstance set"
	::errorCheck ${mixinInstance::setVar} 222\
	    "Mixin inheritance: mixinInstance set - value"

	::errorCheck $setFilterResult \
	    "-set-::Object-::Object-set-::AppMixin1-::AppMixin1"  \
	    "Mixin inheritance: Wrong classes in mixin set test"

	Object filter ""
    }

  # Mixin init test
  global initResult
  set initResult ""
  Class A
  A instproc init args {
    [self] mixin B
    global initResult
    append initResult [self class]-
    next
  }

  Class C
  C instproc init args {
    global initResult
    append initResult [self class]-
    next
  }

  Class B -superclass C
  B instproc init args {
    global initResult
    append initResult [self class]-
    next
  }

  Class D
  D instproc init args {
    global initResult
    append initResult [self class]-
    next
  }

  A a
  ::errorCheck $initResult \
      "::A-" \
      "Mixin init 1 failed"
  set initResult ""
  # in A mixin changes to B - before D's constructor must 
  # be called
  A b -mixin D
  ::errorCheck $initResult \
      "::D-::A-" \
      "Mixin init 2 failed"

  Class Mix
  Mix instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class Mix1
  Mix1 instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class Mix2
  Mix2 instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class A
  A instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class B
  B instproc init args {
    [self] mixin {Mix Mix1}
    global initResult
    append initResult [self class]-
    next
  }

  set initResult ""
  A a
  a mixin {Mix Mix1}
  ::errorCheck $initResult \
      "::A-" \
      "Mixin init 3 failed"

  set initResult ""
  B b
  ::errorCheck $initResult \
      "::B-" \
      "Mixin init 4 failed"

  set initResult ""
  B mixinappend Mix2
  ::errorCheck $initResult \
      "" \
      "Mixin init 5 failed"

  set initResult ""
  A mixin {}; A mixin {Mix Mix1}
  ::errorCheck $initResult \
      "" \
      "Mixin init 6 failed"

  set initResult ""
  A a -mixin {Mix}
  ::errorCheck $initResult \
      "::Mix-::A-" \
      "Mixin init 7 failed"

  Class Strategy
  Strategy instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class A
  A instproc strategy {n} {
    set a [[self] info mixin]
    [self] mixin [concat $n $a]
  }
  A instproc init args {
    global initResult
    append initResult [self class]-
    next
  }
  Class Mix1
  Mix1 instproc init args {
    global initResult
    append initResult [self class]-
    [self] strategy Strategy
    next
  }
  set initResult ""
  A a -mixin Mix1
  ::errorCheck $initResult \
      "::Mix1-::A-" \
      "Mixin init 8 failed"

  set initResult ""
  Class X
  X instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  Class Y -superclass X
  Y instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  
  Class U -superclass X
  U instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  Class V 
  V instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  
  Class A
  A instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  Class B -superclass A
  B instproc init args {
    append ::initResult " [self]: [self class]->[self proc]"
    next
  }
  A a
  a mixin X
  B b
  b mixin Y
  A a2 -mixin Y
  B b2 -mixin X
  A a3 -mixin {U V}
  B b3
  b3 mixin {U V}
  A a3
  A instmixin X
  A instmixin {}
  B instmixin Y
  B b3
  b3 mixin Y
  
  ::errorCheck $initResult \
      " ::a: ::A->init ::b: ::B->init ::b: ::A->init ::a2: ::Y->init ::a2: ::X->init ::a2: ::A->init ::b2: ::X->init ::b2: ::B->init ::b2: ::A->init ::a3: ::U->init ::a3: ::X->init ::a3: ::V->init ::a3: ::A->init ::b3: ::B->init ::b3: ::A->init ::a3: ::A->init ::b3: ::Y->init ::b3: ::X->init ::b3: ::B->init ::b3: ::A->init" \
      "Mixin init 9 failed"

  return "PASSED [self]"
}

TestX copymove
@ TestX copymove { 
    description {
	Regression test for copy/move methods
    }
}
copymove proc run {{n 50}} {
  # Composite
  Class Composite -superclass Class
  Composite instproc addop {op} {
    [self] instvar ops
    set ops($op) $op
  }
  Composite instproc compositeFilter args {
    set m [self calledproc]
    set c [self regclass]
    set r [next]

    if {[info exists ${c}::ops($m)]} {
      foreach child [[self] info children] {
	eval [self]::$child $m $args
      }
    }
    return $r
  } 
  
  Composite AbstractNode
  AbstractNode abstract instproc iterate v
  AbstractNode addop iterate
  for {set i 0} {$i < $n} {incr i} {
    #
    # class copy
    #
    Class X 
    Class X::Y
    Class X::Y::Z -parameter {
      {param1 1}
      {param2 2}
    }
    #X::Y::Z metadata add {Version Author Nothing}
    #X::Y::Z metadata Version {0.0.9}
    #X::Y::Z metadata Author {Uwe}
    X::Y::Z instproc defaultValueIP {{a defA} {b defB} v} {
      return
    }
    X::Y::Z proc defaultValueP {{c defC} {d defD} v} {
      return
    }

    X::Y::Z instinvar {{7 > 6} {
      #a comment
    }
    }
    X::Y::Z instproc assProc {} {puts x} {{5 > 4} {
      #pre
    }} {{5 > 4} {
      #post
    }
    }
  
    X::Y::Z check {pre post instinvar}

    foreach C {X X::Y X::Y::Z} {
      $C instproc q {a b c} {
	return [self]--[self class]--[self proc]--[next]--
      }
    }
    X::Y::Z z
    X::Y::Z copy V
    V v
    ::errorCheck "[z q 1 2 3]--[X::Y::Z info class]--[X::Y::Z info classparent]" \
      "::z--::X::Y::Z--q------::Class--::XOTclClasses::X::Y"\
      "class copy z"
    ::errorCheck "[v q 1 2 3]--[V info class]--[V info classparent]" "::v--::V--q------::Class--::XOTclClasses"\
      "class copy v"
    ::errorCheck "[::cutSpaces [V info parameter]--[v set param1]--[v set param2]]" \
      " {param1 1} {param2 2} --1--2" \
      "parameter test"
    ::errorCheck "[::cutSpaces [V info instinvar]--[V info instpre assProc]--[V info instpost assProc]]"\
      "{7 > 6} { #a comment }--{5 > 4} { #pre }--{5 > 4} { #post }"\
      "Copy Class Assertions"
    #::errorCheck "[V info metadata]--[V metadata Author]--[V metadata Version]--[V metadata Nothing]"\
      "Version Author Nothing--Uwe--0.0.9--"\
      "Copy Metadata"
    
    set df1 [V info default defaultValueP v dfv1]
    set df2 [V info default defaultValueP c dfv2]
    set df3 [V info instdefault defaultValueIP v dfv3]
    set df4 [V info instdefault defaultValueIP a dfv4]
    ::errorCheck "$df1 $dfv1 $df2 $dfv2 $df3 $dfv3 $df4 $dfv4"\
      "0  1 defC 0  1 defA"\
      "Copy Default Values"
    
    # class hierarchy copy
    Class O
    X copy O::X
    O::X x1; O::X::Y y1; O::X::Y::Z z1
    ::errorCheck "[x1 q 1 2 3]--[y1 q 1 2 3]--[z1 q 1 2 3]" \
      "::x1--::O::X--q------::y1--::O::X::Y--q------::z1--::O::X::Y::Z--q----"\
      "class hierarchy copy"
    #
    # object copy
    #
    X x -set var1 12
    proc ::x::tclProc args {return tclProc}
    x proc q {a b c} {return [self]--[self class]--[self proc]--[next]--}
    x copy y
    ::errorCheck "[::y::tclProc]--[x q 1 2 3]--[y q 1 2 3]" \
      "tclProc--::x----q--::x--::X--q--------::y----q--::y--::X--q------"\
      "object copy"
    # object hierarchy copy
    x copy x::a
    
    x copy x::a::z
    
    ::errorCheck "[::x::a::tclProc]--[::x::a::z::a::tclProc]" \
      "tclProc--tclProc"\
      "object hierarchy copy"

    Class O
    O x
    x invar {{7 > 5} {
      #a comment
    }}
    x proc assProc {} {return} {{5 > 3} {
      #pre
    }} {{5 > 4} {#post
    }}
    x set var1 12
    x proc p1 {} {return [self]-p1}
    x copy y
    ::errorCheck "[x p1]--[x set var1]--[::x info class]" "::x-p1--12--::O"\
      "Simple Copy - Origin"
    ::errorCheck "[y p1]--[y set var1]--[::y info class]" "::y-p1--12--::O"\
      "Simple Copy - Duplicate"
    ::errorCheck "[::cutSpaces [y info invar]--[y info pre assProc]--[y info post assProc]]"\
      "{7 > 5} { #a comment }--{5 > 3} { #pre }--{5 > 4} {#post }"\
      "Copy Obj Assertions"

    #
    # move test
    #
    V destroy
    X::Y::Z move V
    V v

    ::errorCheck "[v q 1 2 3]--[V info class]--[V info classparent]" "::v--::V--q------::Class--::XOTclClasses"\
      "class move v"
    ::errorCheck "[::cutSpaces [V info parameter]--[v set param1]--[v set param2]]" \
      " {param1 1} {param2 2} --1--2" \
      "parameter move test"
    ::errorCheck "[::cutSpaces [V info instinvar]--[V info instpre assProc]--[V info instpost assProc]]"\
      "{7 > 6} { #a comment }--{5 > 4} { #pre }--{5 > 4} { #post }"\
      "Move Class Assertions"
    #::errorCheck "[V info metadata]--[V metadata Author]--[V metadata Version]--[V metadata Nothing]"\
      "Version Author Nothing--Uwe--0.0.9--"\
      "Move Metadata"
    
    set df1 [V info default defaultValueP v dfv1]
    set df2 [V info default defaultValueP c dfv2]
    set df3 [V info instdefault defaultValueIP v dfv3]
    set df4 [V info instdefault defaultValueIP a dfv4]
    ::errorCheck "$df1 $dfv1 $df2 $dfv2 $df3 $dfv3 $df4 $dfv4"\
      "0  1 defC 0  1 defA"\
      "Move Default Values"
    
    ::errorCheck "[::info commands X::Y::Z]"\
      ""\
      "Moved command still exists"

    #
    # copy with filters test
    # 
    foreach filters {{} compositeFilter} {
      Composite filter $filters
      AbstractNode filter $filters
      Object commands
      Class Commands -superclass AbstractNode
      Class Command -superclass Commands
      Command instproc init args {
	[self] instvar label
	set label [self]
	next
      }
      Command instproc setlabel {{arg ""}} {
	[self] instvar label
	if {$arg == ""} {
	  set label
	} else {
	  set label $arg
	}
      }
      Command instproc setproc {value} {
	[self] instvar src 
	set src $value
      }
      # prototypes
      Command commands::cellcmd
      commands::cellcmd setlabel cell
      commands::cellcmd setproc {return "coucou" }
      commands::cellcmd proc x args {return xxx}
      commands::cellcmd copy toto
      ::errorCheck [::toto info class] ::Command\
	"Copy with Filter: info class"
      ::errorCheck [toto set label] cell\
	"Copy with Filter: set var"
      ::errorCheck [toto x] xxx\
	"Copy with Filter: call proc"
      ::errorCheck [commands::cellcmd set label] cell\
	"Copy with Filter: set var"
    }
  }
  return "PASSED [self]"
}

TestX recreation
@ TestX recreation  {
    description {
	Regression test for object recreation/cleanup.
    }
}
recreation proc run {{n 50}} {
 for {set i 0} {$i < $n} {incr i} {
  set ::recreateResult ""
  Class R
  R instproc recreate args {
    global recreateResult
    append recreateResult "*recreate [self] $args* "
    set r [next]
    append recreateResult "*recreate [self] <[lindex $args 0]> $r * "
    return $r
  }
  Object instmixin R

  catch {
    C destroy
    c1 destroy
  }
  Class C -parameter {a b}
  C instproc cProc {} {return cProc}
  C set r 4
  C set v 5
  
  C c1 -a 1
  c1 proc x {} {return p}
  c1 set x 3
  C c1 -b 2
  append ::recreateResult "+[c1 info vars],"
  append ::recreateResult "[c1 info procs] +"
  
  Class C
  C set w 3
  append ::recreateResult "+[C info vars],"
  append ::recreateResult "[C info instprocs] +"
  errorCheck [set ::recreateResult] \
    "*recreate ::C c1 -b 2* *recreate ::C <c1> c1 * +b, +*recreate ::Class C* *recreate ::Class <C> C * +w, +" \
    "Var/proc recreate delete failed"

  global recreateMixinResult
  global recreateFilterResult
  set recreateMixinResult ""
  set recreateFilterResult ""
  Class RecreateObserve
  foreach ip {create destroy instdestroy init configure 
    recreate cleanup alloc class} {
    RecreateObserve instproc $ip args {
      append ::recreateMixinResult " [self]+[self class]->[self proc]"
      next
    }
  }

  Class Recreated
  Recreated instproc recreationFilter args {
    append ::recreateFilterResult " [self]+[self calledclass]->[self calledproc]"
    next
  }
  Recreated filter recreationFilter
  Recreated mixin RecreateObserve
  Recreated instmixin RecreateObserve

  Recreated recreateObj
  Recreated recreateObj
  recreateObj destroy
  errorCheck [set ::recreateFilterResult] \
    " ::recreateObj+::Object->configure ::recreateObj+::Object->init ::recreateObj+::Object->class ::recreateObj+::Object->cleanup ::recreateObj+::Object->configure ::recreateObj+::Object->init ::recreateObj+::Object->destroy" \
    "recreateObj - recreateFilterResult"
   if {$i == 0} {
     errorCheck [set ::recreateMixinResult] \
       " ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->alloc ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::Recreated+::RecreateObserve->create ::recreateObj+::RecreateObserve->class ::recreateObj+::RecreateObserve->cleanup ::Recreated+::RecreateObserve->recreate ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::recreateObj+::RecreateObserve->destroy ::Recreated+::RecreateObserve->instdestroy" \
       "recreateObj - recreateMixinResult"
   } else { 
     errorCheck [set ::recreateMixinResult] \
       " ::Recreated+::RecreateObserve->class ::Recreated+::RecreateObserve->cleanup ::Recreated+::RecreateObserve->create ::Recreated+::RecreateObserve->alloc ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::Recreated+::RecreateObserve->create ::recreateObj+::RecreateObserve->class ::recreateObj+::RecreateObserve->cleanup ::Recreated+::RecreateObserve->recreate ::recreateObj+::RecreateObserve->configure ::recreateObj+::RecreateObserve->init ::recreateObj+::RecreateObserve->destroy ::Recreated+::RecreateObserve->instdestroy" \
       "recreateObj - recreateMixinResult"
   }
 }

  set ::cleanupResult ""

  catch {a destroy}
  catch {A destroy}
  catch {X destroy}
  catch {META destroy}

  Class A
  A proc instdestroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  A proc recreate args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  A instproc destroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  A instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}

  A a
  A a::b
  errorCheck [set ::cleanupResult] \
   "" \
   "Cleanup Create Failed"
  A a
  errorCheck [a info children] \
   "" \
   "Cleanup Object Children Destroy Failed"
  A a::b
  errorCheck [set ::cleanupResult] \
   " ::a+::A->cleanup ::a::b+::A->destroy ::A+->instdestroy ::A+->recreate" \
   "Cleanup a/a::b Failed"

  a destroy;
  set ::cleanupResult ""
  A instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"}

  A a
  A a::b
  errorCheck [set ::cleanupResult] \
   "" \
   "Cleanup Redefine Create Failed"
  A a
  errorCheck [a info children] \
   "::a::b" \
   "Cleanup Redefine Object Children Survive Failed"
  A a::b
  errorCheck [set ::cleanupResult] \
   " ::a+::A->cleanup ::A+->recreate ::a::b+::A->cleanup ::A+->recreate" \
   "Cleanup Redefine a/a::b Failed"

  a destroy
  set ::cleanupResult ""


  Class META -superclass Class
  META proc instdestroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  META proc recreate args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  META instproc destroy args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}
  META instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"; next}

  META X
  META X::Y
  errorCheck [set ::cleanupResult] \
   "" \
   "Class Cleanup Create Failed"
  META X
  errorCheck [X info classchildren] \
   "" \
   "Class Cleanup Class Children Destroy Failed"
  META X::Y
  errorCheck [set ::cleanupResult] \
   " ::X+::META->cleanup ::X::Y+::META->destroy ::META+->instdestroy ::META+->recreate" \
   "Class Cleanup X/X::Y Failed"

  X destroy;
  set ::cleanupResult ""
  META instproc cleanup args {append ::cleanupResult " [self]+[self class]->[self proc]"}

  META X
  META X::Y
  errorCheck [set ::cleanupResult] \
   "" \
   "Class Cleanup Redefine Create Failed"
  META X
  errorCheck [X info classchildren] \
   "::X::Y" \
   "Class Cleanup Redefine Class Children Survive Failed"
  META X::Y
  errorCheck [set ::cleanupResult] \
   " ::X+::META->cleanup ::META+->recreate ::X::Y+::META->cleanup ::META+->recreate" \
   "Class Cleanup Redefine X/X::Y Failed"

  X destroy
  A destroy
  META destroy
  unset ::cleanupResult

  return "PASSED [self]"
}


TestX smallScripts
@ TestX smallScripts  {
    description {
	Regression test object testing arbitrary features.
    }
}
proc ::up1 {} {
    return [uplevel self]
}	
proc ::up3 {} {
    return [uplevel 3 self]
}
proc ::up2 {} {
    return [up3]
}
smallScripts proc run {{n 50}} {
    # uplevel test
    for {set i 0} {$i < $n} {incr i} {	
	Object o
	o proc u2 {} {return [::up2]}
	o proc u1 {} {return [::up1]}
	
	Class SM
	SM instproc init args {
	    if {[o u1] != "::o" || [o u2] != "::s"} { 
		puts stderr "FAILED - UpLevel Test failed"
		exit
	    }
	}
	SM s
    }

    for {set i 0} {$i < $n} {incr i} {
      Class A
      A a
      set oname1 [Object autoname ooo]
      set oname2 [Object autoname -instance OOO]
      A autoname  -reset AAA
      set names [A autoname AAA]
      a autoname -reset aaa
      lappend names [a autoname aaa]
      lappend names [a autoname aaa]
      ::errorCheck $names "AAA0 aaa0 aaa1" \
	"Autoname creation"
      ::errorCheck $oname1 "ooo$i" \
	"Autoname Object 1"
      ::errorCheck $oname2 "oOO$i" \
	"Autoname Object 2"
      ::errorCheck [set Object::__autonames(ooo)] $i \
	"Autoname Object Count"
    }

    return "PASSED [self]"
}

TestX proc run {} {  
  puts [nestingClasses run]
  puts [nestingObjects run]
  puts [assertions run]
  puts [stdargs run]
  puts [filterAddRemove run]
  puts [filterClassChange run]
  puts [filterSimpleObserver run]
  puts [filterInfo run]
  puts [nextTest run]
  puts [init_params run]
  puts [mixinTest run]
  puts [mixinInheritanceTest run]
  puts [copymove run]
  puts [recreation run]
  puts [smallScripts run]
}
puts "XOTcl - Test"
puts "Time used: [time {TestX run} 1]"
