Basic Tcl testing sample

tctest.tcl

# Checks if the argument string is blank
proc is_blank {x} {
    return [string equal $x {}]
}

namespace eval fixture {
    namespace export create execute
    namespace ensemble create

    # Creates a new fixture, which contains a group of tests and an optional
    # setup and teardown:
    #
    # fixture create sample {
    #   setup { puts "--> Starting $test" }
    #   teardown { puts "<-- Stopping $test" }
    #
    #   test trivial { assert equal 1 1 }
    # }
    #
    proc create {name body} {    
        # All the fixture metadata is bound in a subnamespace, to avoid
        # the user overwriting framework data by accident        
        set private_ns [string cat ::tctest::fixtures::$name ::private]

        namespace eval $private_ns {
            variable tests {}
            variable setup_body
            variable teardown_body
        }

        # $name isn't accessible within the namespace block,
        # which is why this code has to be generated
        namespace eval $private_ns [list variable name $name]

        namespace eval ::tctest::fixtures::$name {
            proc setup {body} {
                set name $private::name
                set private::setup_body [list {test} $body ::tctest::fixtures::$name]
            }

            proc teardown {body} {
                set name $private::name
                set private::teardown_body [list {test} $body ::tctest::fixtures::$name]
            }

            setup {}
            teardown {}

            proc test {name body} {
                lappend private::tests $name
                proc $name {} $body
            }
        }

        namespace eval ::tctest::fixtures::$name $body
    }

    # Executes each test in the fixture (surrounded by the setup and teardown),
    # and informs the reporter about the status of each test.
    #
    # fixture execute sample {
    #   {status fixture test message}
    #   {
    #     switch $status {
    #       pass { puts "\[$fixture\] PASSED: $test" }
    #       fail { puts "\[$fixture\] FAILED: $test\n  Reason: $message "}
    #   }
    # }   
    #
    proc execute {name report} {
        set private_ns [string cat ::tctest::fixtures::$name ::private]
        
        # Similar to the fixture name case, we have to inject this value
        # into somewhere accessible in the fixture namespace
        namespace eval $private_ns [list variable current_report $report]

        namespace eval ::tctest::fixtures::$name {
            foreach test $private::tests {
                apply $private::setup_body $test

                if [catch {$test} message] {
                    apply $private::current_report fail $private::name $test $message
                } else {
                    apply $private::current_report pass $private::name $test ""
                }

                apply $private::teardown_body $test
            }
        }

        namespace eval $private_ns [list variable current_report ""]
    }
}

namespace eval assert {
    namespace export equal
    namespace ensemble create

    # Compares an expected value with the output of an actual expr,
    # and generates an error if the two values do not match. By
    # default, the comparator is expr's ==, but other comparators
    # can also be used:
    #
    #   # Default
    #   assert equal 2 {5 - 3}
    #
    #   # Custom
    #   assert equal / {[get_root_fs_path]} {string equal $a $b}
    #
    proc equal {expected actual {cmp ""}} {
        set actual_value [uplevel 1 "expr {$actual}"]

        if [is_blank $cmp] {
            set cmp_func [list {a b} {return [expr {$a == $b}]}]
        } else {
            set cmp_func [list {a b} $cmp]
        }

        if {![apply $cmp_func $expected $actual_value]} {
            error "Expected $actual to be $expected, not $actual_value"
        }
    }
}

namespace eval console_report {
    namespace export create callback display
    namespace ensemble create

    # Initializes a new console reporter
    #
    #   console_report create sample
    #
    proc create {name} {
        namespace eval ::tctest::report::console::$name {
            variable passed {}
            variable failed {}
        }
    }
    
    # This is what the callback function invokes, to actually handle
    # the details of reporting a test result
    proc report {name status fixture test message} {
        set passed_var [string cat ::tctest::report::console::$name ::passed]
        set failed_var [string cat ::tctest::report::console::$name ::failed]

        switch $status {
            pass {
                lappend $passed_var $fixture $test
            }

            fail {
                lappend $failed_var $fixture $test $message
            }
        }
    }

    # Provides a fucntion that can be passed to fixture execute. This
    # can be used across multiple fixtures, if you want to aggregate
    # the results of all of them into a single report.
    #
    #  fixture execute utils [console_report callback sample]
    #  fixture execute core [console_report callback sample]
    #
    proc callback {name} {
        set body "report $name \$status \$fixture \$test \$message"
        return [list {status fixture test message} $body ::console_report]
    }

    # Prints the report onto the console
    #
    #  console_report display sample
    #
    proc display {name} {
        set passed_var [string cat ::tctest::report::console::$name ::passed]
        set failed_var [string cat ::tctest::report::console::$name ::failed]

        set passed [set $passed_var]
        set failed [set $failed_var]

        puts "# Report: $name"
        puts "## Stats"
        puts "Passed: [expr {[llength $passed] / 2}]"
        puts "Failed: [expr {[llength $failed] / 3}]"
        puts "## Failures"
        foreach {fixture test message} $failed {
            puts "- In $fixture.$test\n    $message"
        }
    }
}

# Run this script to see this test output:
#
#  tclsh tctest.tcl

fixture create plus {
    test zero_zero { assert equal 0 {0 + 0} }
    test zero_one { assert equal 1 {0 + 1} }
    test one_zero { assert equal 1 {1 + 0} }
}

fixture create mul {
    test two_one { assert equal 2 {2 * 1} }
    test one_two { assert equal 3 {1 * 2} }
}

console_report create arithmetic
fixture execute plus [console_report callback arithmetic]
fixture execute mul [console_report callback arithmetic]
console_report display arithmetic