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
142
143
144
|
#! /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 bigmem [expr {[
info exists ::env(TCL_TESTCONSTRAINT_BIGMEM)]
? !!$::env(TCL_TESTCONSTRAINT_BIGMEM)
: 1
}]
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
}
# Return Windows version as FULLVERSION MAJOR MINOR BUILD REVISION
if {$::tcl_platform(platform) eq "windows"} {
proc windowsversion {} {
set ver [regexp -inline {(\d+).(\d+).(\d+).(\d+)} [exec {*}[auto_execok ver]]]
proc windowsversion {} [list return $ver]
return [windowsversion]
}
proc windowsbuildnumber {} {
return [lindex [windowsversion] 3]
}
proc windowscodepage {} {
# Note we cannot use result of chcp because that returns OEM code page.
package require registry
set cp [registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP]
proc windowscodepage {} "return cp$cp"
return [windowscodepage]
}
}
}
init
package provide tcltests 0.1
}
|
