blob: 409a2ccfabf4107069211ad7846f9fdc1b6a18f7 (
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
114
115
116
117
118
119
120
|
#! /usr/bin/env tclsh
# Don't overwrite tcltests facilities already present
if {[package provide tcltests] ne {}} return
package require tcltest 2.5
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
testConstraint deprecated [expr {![tcl::build-info no-deprecate]}]
testConstraint debug [tcl::build-info debug]
testConstraint purify [tcl::build-info purify]
testConstraint debugpurify [
expr {
![tcl::build-info memdebug]
&& [testConstraint debug]
&& [testConstraint purify]
}]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [expr {![catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
namespace eval ::tcltests {
proc init {} {
if {[namespace which ::tcl::file::tempdir] eq {}} {
interp alias {} [namespace current]::tempdir {} [
namespace current]::tempdir_alternate
} else {
interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir
}
}
# Stolen from dict.test
proc scriptmemcheck script {
set end [lindex [split [memory info] \n] 3 3]
for {set i 0} {$i < 5} {incr i} {
uplevel 1 $script
set tmp $end
set end [lindex [split [memory info] \n] 3 3]
}
expr {$end - $tmp}
}
proc tempdir_alternate {} {
close [file tempfile tempfile]
set tmpdir [file dirname $tempfile]
set execname [info nameofexecutable]
regsub -all {[^[:alpha:][:digit:]]} $execname _ execname
for {set i 0} {$i < 10000} {incr i} {
set time [clock milliseconds]
set name $tmpdir/${execname}_${time}_$i
if {![file exists $name]} {
file mkdir $name
return $name
}
}
error [list {could not create temporary directory}]
}
# Generates test cases for 0, min and max number of arguments for a command.
# Expected result is as generated by Tcl_WrongNumArgs
# Only works if optional arguments come after fixed arguments
# E.g.
# testnumargs "zipfs mount" "" "?mountpoint? ?zipfile? ?password?"
# testnumargs "lappend" "varName" "?value ...?"
proc testnumargs {cmd {fixed {}} {optional {}} args} {
variable count
set minargs [llength $fixed]
set maxargs [expr {$minargs + [llength $optional]}]
if {[regexp {\.\.\.\??$} [lindex $optional end]]} {
unset maxargs; # No upper limit on num of args
}
set message "wrong # args: should be \"$cmd"
if {[llength $fixed]} {
append message " $fixed"
}
if {[llength $optional]} {
append message " $optional"
}
if {[llength $fixed] == 0 && [llength $optional] == 0} {
append message " \""
} else {
append message "\""
}
set label [join $cmd -]
if {$minargs > 0} {
set arguments [lrepeat [expr {$minargs-1}] x]
test $label-minargs-[incr count($label-minargs)] \
"$label no arguments" \
-body "$cmd" \
-result $message -returnCodes error \
{*}$args
if {$minargs > 1} {
test $label-minargs-[incr count($label-minargs)] \
"$label missing arguments" \
-body "$cmd $arguments" \
-result $message -returnCodes error \
{*}$args
}
}
if {[info exists maxargs]} {
set arguments [lrepeat [expr {$maxargs+1}] x]
test $label-maxargs-[incr count($label-maxargs)] \
"$label extra arguments" \
-body "$cmd $arguments" \
-result $message -returnCodes error \
{*}$args
}
}
init
package provide tcltests 0.1
}
|
