Skip to content

Instantly share code, notes, and snippets.

@adamnew123456
Last active October 7, 2018 17:00
Show Gist options
  • Save adamnew123456/fcec6b60718a1b52b02bda3d80820283 to your computer and use it in GitHub Desktop.
Save adamnew123456/fcec6b60718a1b52b02bda3d80820283 to your computer and use it in GitHub Desktop.
Basic Tcl testing sample
# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment