Tk Library Source Code

Artifact 7ae7adaadad381da535e22bbc4e7e07fa5b6c2b3:

Attachment "simpletest.tcl" to ticket [1861370fff] added by erickb 2007-12-31 20:58:57.

---

namespace eval st {
    variable collect true   ;# Flag to say whether to run tests
    variable tests          ;# Array of lists of tests to run, indexed on namespace
    variable tol 1.0e-7     ;# Tolerance
}

# name is the name of the proc
# annot is a free-form annotation area
# WORD is ignored and could be, for example:
#   tests
#   e.g.
#   where
#
# tests are of the form args -> result
proc st::addproc {name annot WORD testlist} {
    variable tests
    variable collect
    
    set ns [uplevel 1 {namespace current}]
    
    if {$collect} {
        lappend tests($ns) [list $name $testlist]
    }
}

proc st::off {} {
    variable collect
    
    set collect false
}

proc st::on {} {
    variable collect
    
    set collect true
}

# This will default to the default of 1.0e-7 if not specified
proc st::tolerance {{v 1.0e-7}} {
    variable tol
    
    set tol $v
}

proc st::print {} {
    lassign [uplevel 1 st::run] Ntest Nfail errors
    
    if {$Ntest == 1} {
        set ntests "test"
    } else {
        set ntests "tests"
    }
    puts [format "%d %s run" $Ntest $ntests]
    
    if {$Ntest - $Nfail == 1} {
        set ptests "test"
    } else {
        set ptests "tests"
    }
    puts [format "%d %s passed" [expr {$Ntest - $Nfail}] $ptests]
    
    if {$Ntest != 0} {
        puts [format "%.1f%% pass rate" [expr {100 * (1 - double($Nfail)/$Ntest)}]]
    }
    
    puts "\nAll tests:"
    foreach error $errors {
        lassign $error error call res expected
        puts "  Call: $call"
        puts "    Error: $error"
        puts "    Result: $res"
        puts "    Expected: $expected"
        puts ""
    }

}

proc st::run {} {
    variable tests
    variable tol
    
    lassign {0 0} Ntest Nfail
    
    set ns [uplevel 1 {namespace current}]
    
    set errors {}
    
    if [info exists tests($ns)] {
        foreach testset $tests($ns) {
            lassign $testset name testlist
            foreach testitem $testlist {
                # R is a "relationship"
                lassign $testitem arglist R expected
                if [catch {uplevel 1 $name {*}$arglist} res] {
                    lappend errors [list \
                        $res \
                        "$ns\:\:$name $arglist" \
                        "NA" \
                        $expected
                    ]
                    incr Nfail
                } else {    
                    switch -- $R {
                    ->  {
                            if {$res ne $expected} {
                                lappend errors [list \
                                    "Result did not match expected value" \
                                    "$ns\:\:$name $arglist" \
                                    $res \
                                    $expected \
                                ]
                                incr Nfail
                            } else {
                                lappend errors [list \
                                    "PASSED" \
                                    "$ns\:\:$name $arglist" \
                                    $res \
                                    $expected \
                                ]
                            }
                        }
                    ~   {
                            if {![string is double $res] || ![string is double $expected]} {
                                lappend errors [list \
                                    "For ~, result and expected value should both be numbers" \
                                    "$ns\:\:$name $arglist" \
                                    $res \
                                    "$expected \u00B1 $tol" \
                                ]
                                incr Nfail
                            } elseif {abs($res - $expected) >= $tol} {
                                lappend errors [list \
                                    "Result disagrees with expected value within tolerance of $tol" \
                                    "$ns\:\:$name $arglist" \
                                    $res \
                                    "$expected \u00B1 $tol" \
                                ]
                                incr Nfail
                            } else {
                                lappend errors [list \
                                    "PASSED" \
                                    "$ns\:\:$name $arglist" \
                                    $res \
                                    "$expected \u00B1 $tol" \
                                ]
                            }
                        }
                    }
                }
                incr Ntest
            }
        }
    }
    return [list $Ntest $Nfail $errors]
}