package provide xotcl::test 1.03
@ @File {description {
  Simple regression test support.
  }
}

@ Class Test {
  description {
    Class Test is used to configure test instances, which can 
    be configured by the following parameters:
    <@ul>
    <@li>cmd: the command to be executed</@li>
    <@li>expected: the expected result</@li>
    <@li>count: number of executions of cmd</@li>
    <@li>pre: a command to be executed at the begin of the test (before cmd)</@li>
    <@li>post: a command to be executed after the test (after all cmds)</@li>
    </@ul>
    The defined tests can be executed by <@tt>Test run</@tt>
  }
}

Class Test -parameter {
  cmd 
  {expected 1} 
  {count 1000} 
  msg setResult errorReport
  pre post
}
Test set count 0 
Test proc new args {
  eval my create t[format %.3d [my incr count]] $args
}
Test proc run {} {
  set startTime [clock clicks -milliseconds]
  foreach example [lsort [my allInstances]] {
    $example run
  }
  puts stderr "Total Time: [expr {[clock clicks -milliseconds]-$startTime}] ms"
}
Test proc _allInstances {C} {
  set set [$C info instances]
  foreach sc [$C info subclass] {
    eval lappend set [my _allInstances $sc]
  }
  return $set
}
Test proc allInstances {} {
  return [my _allInstances Test]
}

Test instproc run args {
  my instvar cmd expected pre post count msg
  if {[info exists pre]} {eval $pre}
  if {![info exists msg]} {set msg $cmd}
  set r [eval $cmd]
  if {[my exists setResult]} {set r [eval [my set setResult]]}
  if {$r == $expected} {
    if {[info exists count]} {set c $count} {set c 1000}
    if {$c > 1} {
      #set r0 [time $cmd $c]
      #puts stderr "time {time $cmd $c}"
      set r1 [time {time $cmd $c}]
      #regexp {^(-?[0-9]+) +} $r0 _ mS0
      regexp {^(-?[0-9]+) +} $r1 _ mS1
      set ms [expr {$mS1*1.0/$c}]
      puts stderr "[self]:\t[format %6.1f $ms] mms, $msg"
    } else {
      puts stderr "[self]: $msg ok"
    }
  } else {
    puts stderr "[self]:\tincorrect result for '$msg'"
    puts stderr "\texpected: '$expected', got '$r' [my exists errorReport]"
    if {[my exists errorReport]} {eval [my set errorReport]}
    exit -1
  }
  if {[info exists post]} {eval $post}
}