tcltest.tcl

Swarm,由圣塔菲研究所开发,用于复杂适应系统(CAS)仿真及其他

    # errors go to stderr by default
    Default errorChannel stderr
    proc errorChannel { {filename ""} } {
	variable errorChannel
	variable ChannelsWeOpened

	# This is subtle and tricky.  See the comment above in
	# [outputChannel] for a detailed explanation.
	debug

	if {[llength [info level 0]] == 1} {
	    return $errorChannel
	}
	if {[info exists ChannelsWeOpened($errorChannel)]} {
	    close $errorChannel
	    unset ChannelsWeOpened($errorChannel)
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set errorChannel $filename
	    }
	    default {
		set errorChannel [open $filename a]
		set ChannelsWeOpened($errorChannel) 1

		# If we created the file in [temporaryDirectory], then
		# [cleanupTests] will delete it, unless we claim it was
		# already there.
		set outdir [normalizePath [file dirname \
			[file join [pwd] $filename]]]
		if {[string equal $outdir [temporaryDirectory]]} {
		    variable filesExisted
		    FillFilesExisted
		    set filename [file tail $filename]
		    if {[lsearch -exact $filesExisted $filename] == -1} {
			lappend filesExisted $filename
		    }
		}
	    }
	}
	return $errorChannel
    }

##### Set up the configurable options
    #
    # The configurable options of the package
    variable Option; array set Option {}

    # Usage strings for those options
    variable Usage; array set Usage {}

    # Verification commands for those options
    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are
    # historically associated with an exported variable.  If that variable
    # is already set, support compatibility by accepting its pre-set value.
    # Use [trace] to establish ongoing connection between the deprecated
    # exported variable and the modern option kept as a true internal var.
    # Also set up usage string and value testing for the option.
    proc Option {option value usage {verify AcceptAll} {varName {}}} {
	variable Option
	variable Verify
	variable Usage
	variable OptionControlledVariables
	set Usage($option) $usage
	set Verify($option) $verify
	if {[catch {$verify $value} msg]} {
	    return -code error $msg
	} else {
	    set Option($option) $msg
	}
	if {[string length $varName]} {
	    variable $varName
	    if {[info exists $varName]} {
		if {[catch {$verify [set $varName]} msg]} {
		    return -code error $msg
		} else {
		    set Option($option) $msg
		}
		unset $varName
	    }
	    namespace eval [namespace current] \
	    	    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....
	    # Track all the variables tied to options
	    lappend OptionControlledVariables $varName
	    # Later, set auto-configure read traces on all
	    # of them, since a single trace on Option does not work.
	    proc $varName {{value {}}} [subst -nocommands {
		if {[llength [info level 0]] == 2} {
		    Configure $option [set value]
		}
		return [Configure $option]
	    }]
	}
    }

    proc MatchingOption {option} {
	variable Option
	set match [array names Option $option*]
	switch -- [llength $match] {
	    0 {
		set sorted [lsort [array names Option]]
		set values [join [lrange $sorted 0 end-1] ", "]
		append values ", or [lindex $sorted end]"
		return -code error "unknown option $option: should be\
			one of $values"
	    }
	    1 {
		return [lindex $match 0]
	    }
	    default {
		# Exact match trumps ambiguity
		if {[lsearch -exact $match $option] >= 0} {
		    return $option
		}
		set values [join [lrange $match 0 end-1] ", "]
		append values ", or [lindex $match end]"
		return -code error "ambiguous option $option:\
			could match $values"
	    }
	}
    }

    proc EstablishAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
	}
    }

    proc RemoveAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    foreach pair [trace vinfo $varName] {
		foreach {op cmd} $pair break
		if {[string equal r $op]
			&& [string match *ProcessCmdLineArgs* $cmd]} {
		    trace vdelete $varName $op $cmd
		}
	    }
	}
	# Once the traces are removed, this can become a no-op
	proc RemoveAutoConfigureTraces {} {}
    }

    proc Configure args {
	variable Option
	variable Verify
	set n [llength $args]
	if {$n == 0} {
	    return [lsort [array names Option]]
	}
	if {$n == 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return $Option($option)
	}
	while {[llength $args] > 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    if {[catch {$Verify($option) [lindex $args 1]} value]} {
		return -code error "invalid $option\
			value \"[lindex $args 1]\": $value"
	    }
	    set Option($option) $value
	    set args [lrange $args 2 end]
	}
	if {[llength $args]} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return -code error "missing value for option $option"
	}
    }
    proc configure args {
	RemoveAutoConfigureTraces
	set code [catch {eval Configure $args} msg]
	return -code $code $msg
    }
    
    proc AcceptVerbose { level } {
	set level [AcceptList $level]
	if {[llength $level] == 1} {
	    if {![regexp {^(pass|body|skip|start|error)$} $level]} {
		# translate single characters abbreviations to expanded list
		set level [string map {p pass b body s skip t start e error} \
			[split $level {}]]
	    }
	}
	set valid [list]
	foreach v $level {
	    if {[regexp {^(pass|body|skip|start|error)$} $v]} {
		lappend valid $v
	    }
	}
	return $valid
    }

    proc IsVerbose {level} {
	variable Option
	return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
    }

    # Default verbosity is to show bodies of failed tests
    Option -verbose {body error} {
	Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
	Test suite will display all passed tests if 'p' is specified, all
	skipped tests if 's' is specified, the bodies of failed tests if
	'b' is specified, and when tests start if 't' is specified.
	ErrorInfo is displayed if 'e' is specified.
    } AcceptVerbose verbose

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the
    # testsDirectory and matchDirectories, which defaults to all
    # directories.
    Option -match * {
	Run all tests within the specified files that match one of the
	list of glob patterns given.
    } AcceptList match

    Option -skip {} {
	Skip all tests within the specified tests (via -match) and files
	that match one of the list of glob patterns given.
    } AcceptList skip

    Option -file *.test {
	Run tests in all test files that match the glob pattern given.
    } AcceptPattern matchFiles

    # By default, skip files that appear to be SCCS lock files.
    Option -notfile l.*.test {
	Skip all test files that match the glob pattern given.
    } AcceptPattern skipFiles

    Option -relateddir * {
	Run tests in directories that match the glob pattern given.
    } AcceptPattern matchDirectories

    Option -asidefromdir {} {
	Skip tests in directories that match the glob pattern given.
    } AcceptPattern skipDirectories

    # By default, don't save core files
    Option -preservecore 0 {
	If 2, save any core files produced during testing in the directory
	specified by -tmpdir. If 1, notify the user if core files are
	created.
    } AcceptInteger preserveCore

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or
    # were specifically skipped.  A debug level of 2 would spit up the
    # tcltest variables and flags provided; a debug level of 3 causes
    # some additional output regarding operations of the test harness.
    # The tcltest package currently implements only up to debug level 3.
    Option -debug 0 {
	Internal debug level 
    } AcceptInteger debug

    proc SetSelectedConstraints args {
	variable Option
	foreach c $Option(-constraints) {
	    testConstraint $c 1
	}
    }
    Option -constraints {} {
	Do not skip the listed constraints listed in -constraints.
    } AcceptList
    trace variable Option(-constraints) w \
	    [namespace code {SetSelectedConstraints ;#}]

    # Don't run only the "-constraint" specified tests by default
    proc ClearUnselectedConstraints args {
	variable Option
	variable testConstraints
	if {!$Option(-limitconstraints)} {return}
	foreach c [array names testConstraints] {
	    if {[lsearch -exact $Option(-constraints) $c] == -1} {
		testConstraint $c 0
	    }
	}
    }
    Option -limitconstraints false {
	whether to run only tests with the constraints
    } AcceptBoolean limitConstraints 
    trace variable Option(-limitconstraints) w \
	    [namespace code {ClearUnselectedConstraints ;#}]

    # A test application has to know how to load the tested commands
    # into the interpreter.
    Option -load {} {
	Specifies the script to load the tested commands.
    } AcceptScript loadScript

    # Default is to run each test file in a separate process
    Option -singleproc 0 {
	whether to run all tests in one process
    } AcceptBoolean singleProcess 

    proc AcceptTemporaryDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    file mkdir $directory
	}
	set directory [AcceptDirectory $directory]
	if {![file writable $directory]} {
	    if {[string equal [workingDirectory] $directory]} {
		# Special exception: accept the default value
		# even if the directory is not writable
		return $directory
	    }
	    return -code error "\"$directory\" is not writeable"
	}
	return $directory
    }

    # Directory where files should be created
    Option -tmpdir [workingDirectory] {
	Save temporary files in the specified directory.
    } AcceptTemporaryDirectory temporaryDirectory
    trace variable Option(-tmpdir) w \
	    [namespace code {normalizePath Option(-tmpdir) ;#}]

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative
    # to [testsDirectory]
    Option -testdir [workingDirectory] {
	Search tests in the specified directory.
    } AcceptDirectory testsDirectory
    trace variable Option(-testdir) w \
	    [namespace code {normalizePath Option(-testdir) ;#}]

    proc AcceptLoadFile { file } {
	if {[string equal "" $file]} {return $file}
	set file [file join [temporaryDirectory] $file]
	return [AcceptReadable $file]
    }
    proc ReadLoadScript {args} {
	variable Option
	if {[string equal "" $Option(-loadfile)]} {return}
	set tmp [open $Option(-loadfile) r]
	loadScript [read $tmp]
	close $tmp
    }
    Option -loadfile {} {
	Read the script to load the tested commands from the specified file.
    } AcceptLoadFile loadFile
    trace variable Option(-loadfile) w [namespace code ReadLoadScript]

    proc AcceptOutFile { file } {
	if {[string equal stderr $file]} {return $file}
	if {[string equal stdout $file]} {return $file}
	return [file join [temporaryDirectory] $file]
    }

    # output goes to stdout by default
    Option -outfile stdout {
	Send output from test runs to the specified file.
    } AcceptOutFile outputFile
    trace variable Option(-outfile) w \
	    [namespace code {outputChannel $Option(-outfile) ;#}]

    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace variable Option(-errfile) w \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

}

#####################################################################

# tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
#     dependent on the chosen level. A test shell may overide
#     them, f.e. to redirect the output into a different
#     channel, or even into a GUI.

# tcltest::DebugPuts --
#
#     Prints the specified string if the current debug level is
#     higher than the provided level argument.
#
# Arguments:
#     level   The lowest debug level triggering the output
#     string  The string to print out.
#
# Results:
#     Prints the string. Nothing else is allowed.
#
# Side Effects:
#     None.
#

proc tcltest::DebugPuts {level string} {
    variable debug
    if {$debug >= $level} {
	puts $string
    }
    return
}

# tcltest::DebugPArray --
#
#     Prints the contents of the specified array if the current
#       debug level is higher than the provided level argument
#
# Arguments:
#     level           The lowest debug level triggering the output
#     arrayvar        The name of the array to print out.
#