blob: 1fde188df7b1e5898c73fe895e06c4a117c3bd77 (
plain)
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
|
proc makeFile {contents name} {
set f [open $name w]
puts $f $contents
close $f
}
proc script_source {script} {
lassign [info source $script] f l
if {$f ne ""} {
puts "At : $f:$l"
return \t$f:$l
}
}
proc error_source {} {
lassign [info stacktrace] p f l
if {$f ne ""} {
puts "At : $f:$l"
return \t$f:$l
}
}
proc package-or-skip {name} {
if {[catch {
package require $name
}]} {
puts " --- skipped"
exit 0
}
}
catch {
# Tcl-only things
info tclversion
proc errorInfo {msg} {
return $::errorInfo
}
proc error_source {} {
}
proc script_source {script} {
}
}
proc section {name} {
if {!$::test(quiet)} {
puts "-- $name ----------------"
}
}
set test(numfail) 0
set test(numpass) 0
set test(failed) {}
proc test {id descr script expected} {
if {!$::test(quiet)} {
puts -nonewline "$id "
}
set rc [catch {uplevel 1 $script} result]
# Note that rc=2 is return
if {($rc == 0 || $rc == 2) && $result eq $expected} {
if {!$::test(quiet)} {
puts "OK $descr"
}
incr ::test(numpass)
} else {
if {$::test(quiet)} {
puts -nonewline "$id "
}
puts "ERR $descr"
if {$rc == 0} {
set source [script_source $script]
} else {
set source [error_source]
}
puts "Expected: '$expected'"
puts "Got : '$result'"
incr ::test(numfail)
lappend ::test(failed) [list $id $descr $source $expected $result]
}
}
proc testreport {} {
if {!$::test(quiet) || $::test(numfail)} {
puts "----------------------------------------------------------------------"
puts "FAILED: $::test(numfail)"
foreach failed $::test(failed) {
foreach {id descr source expected result} $failed {}
puts "$source\t$id"
}
puts "PASSED: $::test(numpass)"
puts "----------------------------------------------------------------------\n"
}
if {$::test(numfail)} {
exit 1
}
}
proc testerror {} {
error "deliberate error"
}
set test(quiet) [info exists ::env(testquiet)]
if {[lindex $argv 0] eq "-quiet"} {
incr test(quiet)
}
if {!$test(quiet)} {
puts [string repeat = 40]
puts $argv0
puts [string repeat = 40]
}
|
