A featherweight test harness

package require tclunit

Adds these words to the global namespace ...

zource - a single verb to facilitate quickly resetting the test environment.
test - verb. takes a glob pattern which is matched against the names of the defined testsuites. Uses zource.
testsuite - use this in your source file or in a separate file, to describe collections of tests.
s/b - verb. The primary test. Takes 2 arguments. A cmd, which is valid Tcl inside braces. And an expected value.
s/nb - the negated version of s/b.

Sample interaction.

$ source mything.test 
mything-test
$ test *
==============================================
testsuite 'cannon' : results : 11/11  :  100% 
==============================================
testsuite 'cursor' : results : 11/11  :  100% 
==============================================
testsuite 'makes' : results : 1/1  :  100% 
========================================================
testsuite 'namespacequestions' : results : 1/1  :  100% 
========================================================
testsuite 'rat' : results : 5/5  :  100% 
==========================================
testsuite 'ratv' : results : 5/5  :  100% 
===========================================
testsuite 'trans' : results : 2/2  :  100% 
===========================================
========================================================
testsuite 'generic' : results : 14/15  :  1 test failed.
========================================================
test 'new' failed
s/b [generic::color {kin 8}] ...
...Blue...
   Yellow
=======================================================
testsuite 'command' : results : 7/9  :  2 tests failed.
=======================================================
test 'arithmetic' failed
s/b [command::+ 3] ...
...nsdate {1966 6 4}...
   invalid command name "command::+"
test 'parse' failed
s/b [command::kin 10 25 2014] ...
......
   100

testsuites organize tests.
the '...' ellipsis is used to delimit the expected result - accenting leading and trailing white space.
the actual result is indented by 3 white space, aligning exactly w/ the ellipsis to facilitate a copy/paste workflow.

Example zource:

   zource {
        package forget mytestingenvthing
        source "abs/path/to/file1"
        source "abs/path/to/file2"
        source "path/to/this/file"
   }

Called w/ one argument, means "this is my reset script". Called w/ no argument, means "reset my environment".

Used to reset/re-source everything necessary for testing.

Example testsuite:

package require tclunit

zource {
    source "~/path/projectsrc.tcl"
    source "~/path/projectsrc.test"
    namespace path ::projectns 
}
testsuite ratv {
    test ns {
        s/b {ratv -ns 1 30 12 3} {nsdate {-ns 1 30 12 3}}
        s/b {ratv NS 1 26 13 16} {nsdate {NS 1 26 13 16}}
        s/b {ratv NS 1 24 8 20 leapday} {nsdate {NS 1 24 8 20 leapday}}
    }
    test execdate {
        s/b {lindex [ratv {*}[exec date]] 0} {gcdate}
        s/b {lindex [ratv [exec date]] 0} {gcdate}
    }
    -test execdate2 {
        s/b {ratv {*}[exec date]} {gcdate {2014 7 12}}
        s/b {ratv [exec date]} {gcdate {2014 7 12}}
    }
}
testsuite rat {
    test ns {
        s/b {rat {-ns 1 30 12 3}} {nsdate -ns 1 30 12 3}
        s/b {rat {NS 1 26 13 16}} {nsdate NS 1 26 13 16}
    }
    test execdate {
        s/b {lindex [rat [exec date]] 0} {gcdate}
    }
    -test execdate2 {
        s/b {rat [exec date]} {gcdate 2014 7 12}
    }
}

A testsuite has a title and a collection of tests

A test has a title and a body (collection of statements)

A body is arbitrary tcl code

Example s/b.

testsuite equations {
    test quadratic {
        s/b {quadratic_eq 1 0 -16} {4 -4}
        s/nb {quadratic_eq 1 0 -16} 4
        s/b {quadratic_eq 1 0 -9} {3 -3}
    }
}

s/b and s/nb perform the testing,

eval 1st phrase in the global scope, generating a result
compare result with 2nd phrase.

tclunit.tcl

# tclunit
# a featherweight test harness
###############################################################################
namespace eval tclunit {
    set version 0.3
    variable lastsuiteglob ""
    variable suites
    variable successcount
    variable failcount
    variable testcount
    variable msglog
    variable echoonrepeat 1
    variable logsuccess 0
    variable zourcevalue ""
    variable zourcestate uninitialized
    array set suites {}
    namespace export testsuite s/b s/nb
}
namespace eval tclunitcmds {
    namespace export zource test 
}
###############################################################################
# [ zource ] 
# a proc/parameter.
#  w/ a value; make an assignment
#  w/o no value; eval assignment in global namespace
###############################################################################
proc tclunitcmds::zource {args} {
    variable ::tclunit::zourcestate
    variable ::tclunit::zourcevalue
    if { [llength $args] == 0 } {
        if {$zourcestate eq "uninitialized"} {
            puts "zource uninitialized."
            return
        }
        catch {uplevel #0 $zourcevalue} res
        return
    } else {
        set zourcestate ""
        set zourcevalue {*}$args
    }
}
###############################################################################
# [ test ] 
# w/o args; resets env and repeats last set of tests
# w/ args; globs against the names of currently defined testsuites
###############################################################################
proc tclunitcmds::test {args} {
    zource
    ::tclunit::testrunner $args
}
###############################################################################
# [s/b]
# cmd is presumed to be a statement in tcl
# expected is matched against return value 
# s/b 'expects' them to match
# s/nb 'expects' them to not match
###############################################################################
proc tclunit::s/b {cmd expected} {
    catch {uplevel 1 $cmd} res
    if {$res != $expected} {
        return -code error "s/b \[$cmd\] ...\n...$expected...\n   $res"
    }
}
proc tclunit::s/nb {cmd expected} {
    catch {uplevel 1 $cmd} res
    if {$res == $expected} {
        return -code error "s/nb \[$cmd\] ...\n...$expected...\n   $res"
    }
}
proc tclunit::test {title body} {
    incr ::tclunit::testcount
    if { [catch {uplevel #0 $body} res opts]  } {
        incr ::tclunit::failcount
        lappend ::tclunit::msglog "test '$title' failed\n$res"
    } {
        incr ::tclunit::successcount
        if { $::tclunit::logsuccess } { 
            lappend ::tclunit::msglog "...success : $res" 
        }
    }
}
proc tclunit::-test {title body} {
    # consumes test, does nothing, use to disable a test
}
proc tclunit::testsuite {title tests} {
    # use first testsuite as initial glob value 
    if { $::tclunit::lastsuiteglob eq "" } {
        set ::tclunit::lastsuiteglob $title
    }
    set ::tclunit::suites($title) $tests
}
proc tclunit::testrunner {suiteglob} {
    variable ::tclunit::lastsuiteglob
    variable ::tclunit::suites
    variable ::tclunit::successcount
    variable ::tclunit::failcount
    variable ::tclunit::msglog
    variable ::tclunit::testcount
    variable ::tclunit::echoonrepeat

    if {$suiteglob eq "" || $suiteglob eq {}} {
        if { ![info exists lastsuiteglob] || $lastsuiteglob eq "" } { 
            puts "yawn."
            return
        }
        set suiteglob $lastsuiteglob 
        if {$echoonrepeat} {
            puts "testing: $suiteglob"
        }
    }

    set lastsuiteglob $suiteglob
    set results [list ]
    set hbar0 ""
    set q00 ""

    foreach suite [lsort [array names suites $suiteglob]] {
        set tests $suites($suite)

        set msglog ""
        set failcount 0
        set successcount 0
        set testcount 0

        # run tests
        foreach {test title body} $tests {
            eval [list $test $title $body]
        }

        # collect results
        if {$failcount} {
            lappend results [list $suite $testcount $successcount $failcount $msglog]
        } {
            # print succeesses right away.
            set q0 "testsuite '$suite' : results : $successcount/$testcount  : "
            set q "$q0 100% "
            set p [string repeat = [string length $q]]
            if { [string length $p] > [string length $hbar0] } { set hbar0 $p }
            if { [string length $hbar0] > [string length $q00] } { set hbar0 $p }
            set q00 $q
            puts $hbar0
            puts $q
        }

    }
    # sort fail results
    foreach r [lsort -increasing -integer -index 3 $results] {
        lassign $r suite testcount successcount failcount msglog
        if { $hbar0 ne "" } {
            puts $hbar0
            set hbar0 ""
        }
        set q0 "testsuite '$suite' : results : $successcount/$testcount  : "
        if { $failcount == 1 } {
            set q2 "test failed."
        } {
            set q2 "tests failed."
        }
        set q "$q0 $failcount $q2"
        set p [string repeat = [string length $q]]
        puts $p
        puts $q
        puts $p
        if { $msglog ne "" } {
            puts [join $msglog \n]
        }
    }
    if { $hbar0 ne "" } { puts $hbar0 }

}
proc tclunit::? {} {lsort [info procs ::tclunit::*]}
###############################################################################
namespace import -force tclunit::*
namespace import -force tclunitcmds::*
###############################################################################
package provide tclunit $tclunit::version
###############################################################################

Category Testing