Script to report about tests failing in isolation.

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
set options(-timeout) 10000
set options(-progress) 100

proc readArgs {} {
    global argv
    global options

    foreach {option arg} $argv {
        if {![info exists options($option)]} {
            puts stderr "Unknown option '$option'"
            exit 1
        }
        set options($option) $arg
    }
}

proc getTestFiles {} {
    global options

    set matchFileList [list]
    foreach pattern $options(-file) {
        set tmp [glob -nocomplain -tails \
                     -directory $options(-tcltestdir) $pattern]
        set matchFileList [concat $matchFileList $tmp]
    }
    set matchFileList [lsort -unique $matchFileList]
    set skipFileList [list]
    foreach pattern $options(-notfile) {
        set tmp [glob -nocomplain -tails \
                     -directory $options(-tcltestdir) $pattern]
        set skipFileList [concat $skipFileList $tmp]
    }
    set skipFileList [lsort -unique $skipFileList]
    set matchingFiles [list]
    foreach file $matchFileList {
        if {[lsearch -exact $skipFileList $file] == -1} {
            lappend matchingFiles $file
        }
    }
    if {[llength $matchingFiles] == 0} {
        puts stderr "No test files remain after applying match and\
                     skip patterns!"
        exit 1
    }
    return $matchingFiles
}

proc getTestNames {file} {
    global options
    global gettestnamesCmd

    set cmd "$options(-testapp) $options(-tcltestdir)/$options(-testmain) \
                -verbose error -singleproc 1 "

    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
    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 error "
        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