tcltest.tcl

windows下的GDB insight前端

		unset $varName
	    }
	    namespace eval [namespace current] \
	    	    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug 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
		}
	    }
	}
	# One 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 {
	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.
#
# Results:
#     Prints the contents of the array. Nothing else is allowed.
#
# Side Effects:
#     None.
#

proc tcltest::DebugPArray {level arrayvar} {
    variable debug

    if {$debug >= $level} {
	catch {upvar  $arrayvar $arrayvar}
	parray $arrayvar
    }
    return
}

# Define our own [parray] in ::tcltest that will inherit use of the [puts]
# defined in ::tcltest.  NOTE: Ought to construct with [info args] and
# [info default], but can't be bothered now.  If [parray] changes, then
# this will need changing too.
auto_load ::parray
proc tcltest::parray {a {pattern *}} [info body ::parray]

# tcltest::DebugDo --
#
#     Executes the script if the current debug level is greater than
#       the provided level argument
#
# Arguments:
#     level   The lowest debug level triggering the execution.
#     script  The tcl script executed upon a debug level high enough.
#
# Results:
#     Arbitrary side effects, dependent on the executed script.
#
# Side Effects:
#     None.
#

proc tcltest::DebugDo {level script} {
    variable debug

    if {$debug >= $level} {
	uplevel 1 $script
    }
    return
}

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

proc tcltest::Warn {msg} {
    puts [outputChannel] "WARNING: $msg"
}

# tcltest::mainThread
#
#     Accessor command for tcltest variable mainThread.
#
proc tcltest::mainThread { {new ""} } {
    variable mainThread
    if {[llength [info level 0]] == 1} {
	return $mainThread
    }
    set mainThread $new
}

# tcltest::testConstraint --
#
#	sets a test constraint to a value; to do multiple constraints,
#       call this proc multiple times.  also returns the value of the
#       named constraint if no value was supplied.
#
# Arguments:
#	constraint - name of the constraint
#       value - new value for constraint (should be boolean) - if not
#               supplied, this is a query
#
# Results:
#	content of tcltest::testConstraints($constraint)
#
# Side effects:
#	none

proc tcltest::testConstraint {constraint {value ""}} {
    variable testConstraints