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
|
#! /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
}
}
init
package provide tcltests 0.1
}
|