tcltest.tcl

这是一个Linux下的集成开发环境

# tcltest::test --
#
# This procedure runs a test and prints an error message if the test
# fails.  If verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# match variable, if it matches an element in skip, or if one of the
# elements of "constraints" turns out not to be true.
#
# If testLevel is 1, then this is a top level test, and we record
# pass/fail information; otherwise, this information is not logged and
# is not added to running totals.
#
# Attributes:
#   Only description is a required attribute.  All others are optional.
#   Default values are indicated.
#
#   constraints -	A list of one or more keywords, each of which
#			must be the name of an element in the array
#			"testConstraints".  If any of these elements is
#			zero, the test is skipped. This attribute is
#			optional; default is {}
#   body -	        Script to run to carry out the test.  It must
#		        return a result that can be checked for
#		        correctness.  This attribute is optional;
#                       default is {}
#   result -	        Expected result from script.  This attribute is
#                       optional; default is {}.
#   output -            Expected output sent to stdout.  This attribute
#                       is optional; default is {}.
#   errorOutput -       Expected output sent to stderr.  This attribute
#                       is optional; default is {}.
#   returnCodes -       Expected return codes.  This attribute is
#                       optional; default is {0 2}.
#   setup -             Code to run before $script (above).  This
#                       attribute is optional; default is {}.
#   cleanup -           Code to run after $script (above).  This
#                       attribute is optional; default is {}.
#   match -             specifies type of matching to do on result,
#                       output, errorOutput; this must be a string
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are pre-registered
#			by the tcltest package.  Default value is exact.
#
# Arguments:
#   name -		Name of test, in the form foo-1.2.
#   description -	Short textual description of the test, to
#  		  	help humans understand what it does.
#
# Results:
#	None.
#
# Side effects:
#       Just about anything is possible depending on the test.
#

proc tcltest::test {name description args} {
    global tcl_platform
    variable testLevel
    variable coreModTime
    DebugPuts 3 "test $name $args"

    FillFilesExisted
    incr testLevel

    # Pre-define everything to null except output and errorOutput.  We
    # determine whether or not to trap output based on whether or not
    # these variables (output & errorOutput) are defined.
    foreach item {constraints setup cleanup body result returnCodes
	    match} {
	set $item {}
    }

    # Set the default match mode
    set match exact

    # Set the default match values for return codes (0 is the standard
    # expected return value if everything went well; 2 represents
    # 'return' being used in the test script).
    set returnCodes [list 0 2]

    # The old test format can't have a 3rd argument (constraints or
    # script) that starts with '-'.
    if {[string match -* [lindex $args 0]]
	    || ([llength $args] <= 1)} {
	if {[llength $args] == 1} {
	    set list [SubstArguments [lindex $args 0]]
	    foreach {element value} $list {
		set testAttributes($element) $value
	    }
	    foreach item {constraints match setup body cleanup \
		    result returnCodes output errorOutput} {
		if {[info exists testAttributes(-$item)]} {
		    set testAttributes(-$item) [uplevel 1 \
			    ::concat $testAttributes(-$item)]
		}
	    }
	} else {
	    array set testAttributes $args
	}

	set validFlags {-setup -cleanup -body -result -returnCodes \
		-match -output -errorOutput -constraints}

	foreach flag [array names testAttributes] {
	    if {[lsearch -exact $validFlags $flag] == -1} {
		incr testLevel -1
		set sorted [lsort $validFlags]
		set options [join [lrange $sorted 0 end-1] ", "]
		append options ", or [lindex $sorted end]"
		return -code error "bad option \"$flag\": must be $options"
	    }
	}

	# store whatever the user gave us
	foreach item [array names testAttributes] {
	    set [string trimleft $item "-"] $testAttributes($item)
	}

	# Check the values supplied for -match
	variable CustomMatch
	if {[lsearch [array names CustomMatch] $match] == -1} {
	    incr testLevel -1
	    set sorted [lsort [array names CustomMatch]]
	    set values [join [lrange $sorted 0 end-1] ", "]
	    append values ", or [lindex $sorted end]"
	    return -code error "bad -match value \"$match\":\
		    must be $values"
	}

	# Replace symbolic valies supplied for -returnCodes
	regsub -nocase normal $returnCodes 0 returnCodes
	regsub -nocase error $returnCodes 1 returnCodes
	regsub -nocase return $returnCodes 2 returnCodes
	regsub -nocase break $returnCodes 3 returnCodes
	regsub -nocase continue $returnCodes 4 returnCodes
    } else {
	# This is parsing for the old test command format; it is here
	# for backward compatibility.
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {
	    set constraints [lindex $args 0]
	    set body [lindex $args 1]
	} else {
	    incr testLevel -1
	    return -code error "wrong # args:\
		    should be \"test name desc ?options?\""
	}
    }

    if {[Skipped $name $constraints]} {
	incr testLevel -1
	return
    }

    # Save information about the core file.  
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    set coreModTime [file mtime [file join [workingDirectory] core]]
	}
    }

    # First, run the setup script
    set code [catch {uplevel 1 $setup} setupMsg]
    set setupFailure [expr {$code != 0}]

    # Only run the test body if the setup was successful
    if {!$setupFailure} {

	# Verbose notification of $body start
	if {[IsVerbose start]} {
	    puts [outputChannel] "---- $name start"
	    flush [outputChannel]
	}

	set command [list [namespace origin RunTest] $name $body]
	if {[info exists output] || [info exists errorOutput]} {
	    set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
	} else {
	    set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
	}
	foreach {actualAnswer returnCode} $testResult break
    }

    # Always run the cleanup script
    set code [catch {uplevel 1 $cleanup} cleanupMsg]
    set cleanupFailure [expr {$code != 0}]

    set coreFailure 0
    set coreMsg ""
    # check for a core file first - if one was created by the test,
    # then the test failed
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    # There's only a test failure if there is a core file
	    # and (1) there previously wasn't one or (2) the new
	    # one is different from the old one.
	    if {[info exists coreModTime]} {
		if {$coreModTime != [file mtime \
			[file join [workingDirectory] core]]} {
		    set coreFailure 1
		}
	    } else {
		set coreFailure 1
	    }
	
	    if {([preserveCore] > 1) && ($coreFailure)} {
		append coreMsg "\nMoving file to:\
		    [file join [temporaryDirectory] core-$name]"
		catch {file rename -force \
		    [file join [workingDirectory] core] \
		    [file join [temporaryDirectory] core-$name]
		} msg
		if {[string length $msg] > 0} {
		    append coreMsg "\nError:\
			Problem renaming core file: $msg"
		}
	    }
	}
    }

    # If expected output/error strings exist, we have to compare
    # them.  If the comparison fails, then so did the test.
    set outputFailure 0
    variable outData
    if {[info exists output]} {
	if {[set outputCompare [catch {
	    CompareStrings $outData $output $match
	} outputMatch]] == 0} {
	    set outputFailure [expr {!$outputMatch}]
	} else {
	    set outputFailure 1
	}
    }

    set errorFailure 0
    variable errData
    if {[info exists errorOutput]} {
	if {[set errorCompare [catch {
	    CompareStrings $errData $errorOutput $match
	} errorMatch]] == 0} {
	    set errorFailure [expr {!$errorMatch}]
	} else {
	    set errorFailure 1
	}
    }

    # check if the return code matched the expected return code
    set codeFailure 0
    if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
	set codeFailure 1
    }

    # check if the answer matched the expected answer
    # Only check if we ran the body of the test (no setup failure)
    if {$setupFailure} {
	set scriptFailure 0
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {
	set scriptFailure 1
    }

    # if we didn't experience any failures, then we passed
    variable numTests
    if {!($setupFailure || $cleanupFailure || $coreFailure
	    || $outputFailure || $errorFailure || $codeFailure
	    || $scriptFailure)} {
	if {$testLevel == 1} {
	    incr numTests(Passed)
	    if {[IsVerbose pass]} {
		puts [outputChannel] "++++ $name PASSED"
	    }
	}
	incr testLevel -1
	return
    }

    # We know the test failed, tally it...
    if {$testLevel == 1} {
	incr numTests(Failed)
    }

    # ... then report according to the type of failure
    variable currentFailure true
    if {![IsVerbose body]} {
	set body ""
    }	
    puts [outputChannel] "\n==== $name\
	    [string trim $description] FAILED"
    if {[string length $body]} {
	puts [outputChannel] "==== Contents of test case:"
	puts [outputChannel] $body
    }
    if {$setupFailure} {
	puts [outputChannel] "---- Test setup\
		failed:\n$setupMsg"
    }
    if {$scriptFailure} {
	if {$scriptCompare} {
	    puts [outputChannel] "---- Error testing result: $scriptMatch"
	} else {
	    puts [outputChannel] "---- Result was:\n$actualAnswer"
	    puts [outputChannel] "---- Result should have been\
		    ($match matching):\n$result"
	}
    }
    if {$codeFailure} {
	switch -- $code {
	    0 { set msg "Test completed normally" }
	    1 { set msg "Test generated error" }
	    2 { set msg "Test generated return exception" }
	    3 { set msg "Test generated break exception" }
	    4 { set msg "Test generated continue exception" }
	    default { set msg "Test generated exception" }
	}
	puts [outputChannel] "---- $msg; Return code was: $code"
	puts [outputChannel] "---- Return code should have been\
		one of: $returnCodes"
	if {[IsVerbose error]} {
	    if {[info exists ::errorInfo]} {
		puts [outputChannel] "---- errorInfo: $::errorInfo"
		puts [outputChannel] "---- errorCode: $::errorCode"
	    }
	}
    }
    if {$outputFailure} {
	if {$outputCompare} {
	    puts [outputChannel] "---- Error testing output: $outputMatch"
	} else {
	    puts [outputChannel] "---- Output was:\n$outData"
	    puts [outputChannel] "---- Output should have been\
		    ($match matching):\n$output"
	}
    }
    if {$errorFailure} {
	if {$errorCompare} {
	    puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
	} else {
	    puts [outputChannel] "---- Error output was:\n$errData"
	    puts [outputChannel] "---- Error output should have\
		    been ($match matching):\n$errorOutput"
	}
    }
    if {$cleanupFailure} {
	puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
    }
    if {$coreFailure} {
	puts [outputChannel] "---- Core file produced while running\
		test!  $coreMsg"
    }
    puts [outputChannel] "==== $name FAILED\n"

    incr testLevel -1
    return
}

# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
#
# Side Effects:  Maintains tally of total tests seen and tests skipped.
#
proc tcltest::Skipped {name constraints} {
    variable testLevel
    variable numTests
    variable testConstraints

    if {$testLevel == 1} {
	incr numTests(Total)
    }
    # skip the test if it's name matches an element of skip
    foreach pattern [skip] {
	if {[string match $pattern $name]} {
	    if {$testLevel == 1} {
		incr numTests(Skipped)
		DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
	    }
	    return 1
	}
    }
    # skip the test if it's name doesn't match any element of match
    set ok 0
    foreach pattern [match] {
	if {[string match $pattern $name]} {
	    set ok 1
	    break
	}
    }
    if {!$ok} {
	if {$testLevel == 1} {
	    incr numTests(Skipped)
	    DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
	}
	return 1
    }
    if {[string equal {} $constraints]} {
	# If we're limited to the listed constraints and there aren't
	# any listed, then we shouldn't run the test.
	if {[limitConstraints]} {
	    AddToSkippedBecause userSpecifiedLimitConstraint
	    if {$testLevel == 1} {
		incr numTests(Skipped)
	    }
	    return 1
	}
    } else {
	# "constraints" argument exists;
	# make sure that the constraints are satisfied.

	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}
	    catch {set doTest [uplevel #0 expr $constraints]}
	} elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
	    # something like {a || b} should be turned into
	    # $testConstraints(a) || $testConstraints(b).
	    regsub -all {[.\w]+} $constraints {$tes