-
Notifications
You must be signed in to change notification settings - Fork 4
/
testing.tcl
141 lines (120 loc) · 3.52 KB
/
testing.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#! /usr/bin/env jimsh
# A test framework with constraints.
# Copyright (c) 2014-2016, 2019 D. Bohdan.
# License: MIT.
namespace eval ::testing {
variable version 0.5.0
namespace export *
variable tests {}
variable constraints {}
}
namespace eval ::testing::tests {}
# Generate an error with $expression is not true.
proc ::testing::assert {expression {message ""}} {
if {![uplevel 1 [list expr $expression]]} {
set errorMessage "Not true: $expression"
if {$message ne ""} {
append errorMessage " ($message)"
}
error $errorMessage
}
}
# Compare all args for equality.
proc ::testing::assert-equal args {
set firstArg [lindex $args 0]
foreach arg [lrange $args 1 end] {
assert [list \"$arg\" eq \"$firstArg\"]
}
}
# Tell if we are running Tcl 8.x or Jim Tcl.
proc ::testing::engine {} {
if {[catch {info tclversion}]} {
return jim
} else {
return tcl
}
}
# Return a value from dictionary like dict get would if it is there.
# Otherwise return the default value.
proc ::testing::dict-default-get {default dictionary args} {
if {[dict exists $dictionary {*}$args]} {
dict get $dictionary {*}$args
} else {
return $default
}
}
# Create a new test $name with code $code.
proc ::testing::test args {
variable tests
set name [lindex $args 0]
set options [lrange $args 1 end]
proc ::testing::tests::$name {} [dict get $options -body]
dict set tests $name constraints [dict-default-get "" $options -constraints]
}
proc ::testing::unsat-constraints test {
variable tests
variable constraints
set unsat {}
foreach constraint [dict get $tests $test constraints] {
if {$constraint ni $constraints} {
lappend unsat $constraint
}
}
return $unsat
}
# Run all or selected tests.
proc ::testing::run-tests argv {
variable constraints
lappend constraints [::testing::engine]
set testsToRun $argv
set tests {}
foreach testProc [lsort [info procs ::testing::tests::*]] {
lappend tests [namespace tail $testProc]
}
if {$testsToRun in {"" "all"}} {
set testsToRun $tests
}
set failed {}
set skipped {}
puts {running tests:}
foreach test $tests {
if {$test ni $testsToRun} {
lappend skipped $test {user choice}
continue
}
set unsat [::testing::unsat-constraints $test]
if {$unsat eq {}} {
puts "- $test"
if {[catch {
::testing::tests::$test
} msg opts]} {
set stacktrace [expr {
[::testing::engine] eq {jim}
? [errorInfo $msg [dict get $opts -errorinfo]]
: [dict get $opts -errorinfo]
}]
puts "failed: $stacktrace"
lappend failed $test $opts
}
} else {
lappend skipped $test [concat constraints: $unsat]
}
}
if {$skipped ne {}} {
puts \nskipped:
}
foreach {test reason} $skipped {
puts "- $test ($reason)"
}
set n(total) [llength $tests]
set n(skipped) [expr {[llength $skipped] / 2}]
set n(failed) [expr {[llength $failed] / 2}]
set n(passed) [expr {$n(total) - $n(skipped) - $n(failed)}]
puts \n[list total $n(total) \
passed $n(passed) \
skipped $n(skipped) \
failed $n(failed)]
if {$failed ne {}} {
exit 1
}
}