PTL: implementation

# package require tcltest

   source tcltest.tcl ;# we use a modified tcltest

   set keywords {}
   foreach {kw field descr default clearaftertest} {
     Name: name "Name for this test" test-1.1 1
     Author: author "Author of this test" {} 0
     Ask: ask "Ask a question of a human to check output" {} 1
     Project: project "Project for these tests" {} 0
     Remarks: remarks "Remarks about this test" {} 1
     Description: description "Brief description of the test" {} 1
     Only: -constraints "Only run this test if ..." {} 1 
     Setup: -setup "Run this before the test" {} 1
     AlwaysSetup: always_setup "Run this before the test" {} 0
     Output: -output "Expect this output" {} 1
     Result: -result "Expect this result" {} 1
     Cleanup: -cleanup "Code to cleanup afterwards" {} 1
     AlwaysCleanup: always_cleanup "Code to cleanup afterwards" {} 0
     Match: -match "Matching method exact|glob|regexp|ask" exact 0
   } {
     lappend keywords $kw 
     lappend keywords $field
     set descriptions($kw) $descr
     set defaults($kw) $default
     set clearaftertests($kw) $clearaftertest
   }

   foreach {c k} $keywords {
     set ::_($k) $defaults($c)
     proc $c {args} "set ::_($k) \$args"
   }

   proc AskProc {expected actual} {
     # puts "AskProc '$expected' '$actual'"
     if {$expected == {} &&
         $actual == {}} {
       return 1
     } elseif {$expected == $actual} {
       return 1 
     } else {
       # have to ask the operator
       ask $expected $actual
     }
   }

   tcltest::customMatch ask AskProc

   proc Test: {cmd} {
     set ::_(-body) $cmd
     puts ""
     puts "* $::_(name) - $::_(description)"
     foreach {v k} $::keywords {
       if {$k != "name" && $k != "description"} {
         if {$::_($k) != $::defaults($v)} {
           puts "** $v $::_($k)"
         }
       }
     }

     puts "** Test: [list $::_(-body)]"
     if {$::_(ask) != {}} {
       set ::_(-match) ask
     }

     if {[catch $::options(always_setup) err]} {
       puts "AlwaySetup: $::options(always_setup) failed with $err"
     }
     uplevel \#0 {
       tcltest::test $::_(name) \
           $::_(description) \
           [array get ::_ -*] 
     }
     if {[catch $::options(always_cleanup) err]} {
       puts "AlwaySetup: $::options(always_cleanup) failed with $err"
     }

     foreach {v k} $::keywords {
       if {$::clearaftertests($v)} {
         set ::_($k) {}
       }
     }
   }

Category Testing