Attachment "singletests.tcl" to
ticket [fdcc860df5]
added by
pointsman
2014-11-13 23:20:47.
source [file join [file dirname [info script]] utils.tcl]
set options(-testapp) tcltest
set options(-file) *.test
set options(-notfile) ""
set options(-tcltestdir) "../tests"
set options(-testmain) "all.tcl"
set options(-outfile) "singletests_out_[clock format [clock seconds] \
-format "%Y-%m-%dT%T"].txt"
set options(-overwriteoutfile) 0
# As of tcl8.6.3 the two tests io-14.9 and iocmd.tf-24.17.bug3522560
# have an [after 10000] within the test code and the test regexp-22.5
# in fact runs some seconds it is adviced to not lower -timeout below
# 15000
set options(-timeout) 15000
set options(-progress) 50
proc getTestNames {file} {
global options
global gettestnamesCmd
set namesCmd "$gettestnamesCmd $options(-tcltestdir) $file"
set rawtestnameslist [eval exec $namesCmd]
set testnameslist [lindex [split $rawtestnameslist \n] end]
foreach test $testnameslist {
if {[info exists tmp($test)]} {
puts "File '$file': not unique test name '$test'"
}
incr tmp($test)
}
return $testnameslist
}
# From: http://wiki.tcl.tk/880
proc isReadable { f } {
global tcltestOutput
# The channel is readable; try to read it.
set status [catch { gets $f line } result]
if { $status != 0 } {
# Error on the channel
set ::DONE 2
} elseif { $result >= 0 } {
# Successfully read the channel
append tcltestOutput $line\n
} elseif { [eof $f] } {
# End of file on the channel
set ::DONE 1
} elseif { [fblocked $f] } {
# Read blocked. Just return
} else {
# Something else
set ::DONE 3
}
}
proc testTimeout {} {
global runningTest
global testfile
global test
global summaryfd
global options
puts $summaryfd "file $testfile test $test: Not finished after\
$options(-timeout) milliseconds. Canceling the\
test."
set ::DONE 4
}
proc testOneFile {file} {
global options
global gettestnamesCmd
global testrun
global timeoutID
global testfile
global test
global summaryfd
global tcltestOutput
set testfile $file
puts $file
set testcounter 0
puts -nonewline "#"
foreach test [getTestNames $file] {
incr testcounter
# Show, you're alive. Report progress.
if {$testcounter >= $options(-progress)} {
puts -nonewline "#"
flush stdout
set testcounter 0
}
set test $test
set ::DONE 0
set tcltestOutput ""
set cmd "$options(-testapp) "
append cmd " $options(-tcltestdir)/$options(-testmain) "
append cmd " -file $file -match $test "
append cmd " -verbose {} "
append cmd " -singleproc 1 "
set runningTest [open "| $cmd"]
fconfigure $runningTest -blocking false
fileevent $runningTest readable [list isReadable $runningTest]
set timeoutID [after $options(-timeout) testTimeout]
vwait ::DONE
after cancel $timeoutID
set logmsg "\n\n****************\nfile $testfile test $test: "
switch $::DONE {
1 {
foreach line [split $tcltestOutput "\n"] {
if {[string first $options(-testmain) $line] == 0} {
# This sets the variables Total, Passed,
# Skipped and Failed, as of tcltest 2.3.5.
foreach {what nrOf} [lrange $line 1 end] {
set $what $nrOf
}
if {$Failed != 0} {
append logmsg "Test failed.\n$tcltestOutput"
} else {
set logmsg ""
}
}
}
}
2 {
append logmsg "Error.\n$tcltestOutput"
}
3 {
append logmsg "Irregular read from subprocess\n$tcltestOutput"
}
4 {
# Test cancled after timeout. Already reported,
# don't mess up log.
set logmsg ""
}
default {
# can't happen
append logmsg "Reached 'can't happen' case in testOneFile."
}
}
puts -nonewline $summaryfd $logmsg
close $runningTest
}
puts ""
}
proc init {} {
global options
global gettestnamesCmd
global summaryfd
readArgs
if {![file exists $options(-testapp)]} {
puts stderr "No $::options(-testapp) app in the run dir. Aborting."
exit 1
}
if {![string is boolean -strict $options(-overwriteoutfile)]} {
puts stderr "The option -overwriteoutfile expects a boolean value.\
Aborting."
exit 1
}
if {![string is integer -strict $options(-timeout)]
|| $options(-timeout) <= 0} {
puts string "The option -timeout expects a positive integer as value.\
Aborting."
exit 1
}
if {![string is integer -strict $options(-progress)]} {
puts string "The options -progress expects a positive integer as\
value. Aborting."
exit 1
}
set options(-testapp) [file join [pwd] $options(-testapp)]
set gettestnamesCmd "$::options(-testapp) \
[file join [file dirname [info script]] test-names.tcl]"
if {[file exists $options(-outfile)] && !$options(-overwriteoutfile)} {
puts stderr "Out file '$options(-outfile)' already exists\
and -overwriteoutfile not true. Aborting."
exit 1
}
set summaryfd [open $options(-outfile) w+]
fconfigure $summaryfd -buffering line
puts $summaryfd "Started\
[clock format [clock seconds] -format "%Y-%m-%dT%T"]"
puts $summaryfd "Test file pattern: $options(-file)\n"
}
proc runEveryTestAlone {} {
init
foreach testfile [getTestFiles] {
testOneFile $testfile
}
}
runEveryTestAlone