###############################################################################
#
# test.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Test Package File
#
# Copyright (c) 2007-2012 by Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################
#
# NOTE: Use our own namespace here because even though we do not directly
# support namespaces ourselves, we do not want to pollute the global
# namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::Eagle {
proc dumpState {} {
set result [list]
foreach varName [lsort [uplevel 1 [list info vars]]] {
if {[uplevel 1 [list array exists $varName]]} then {
lappend result $varName [list \
array [uplevel 1 [list array get $varName]]]
} else {
lappend result $varName [list \
scalar [uplevel 1 [list set $varName]]]
}
}
return $result
}
proc trawputs { channel string } {
#
# NOTE: If an output channel was provided, use it; otherwise, ignore
# the message.
#
if {[string length $channel] > 0} then {
#
# NOTE: Check if output is being actively intercepted by us.
#
if {![isEagle] && \
[llength [info commands ::tcl::save::puts]] > 0} then {
::tcl::save::puts -nonewline $channel $string
} else {
puts -nonewline $channel $string
}
}
}
proc tputs { channel string } {
trawputs $channel $string; tlog $string
}
#
# NOTE: This is a shim designed to act like tclLog.
#
proc ttclLog { string } {
tputs $::test_channel [appendArgs $string \n]
}
proc doesTestLogFileExist { fileName } {
if {[catch {
expr {[file exists $fileName] && [file size $fileName] > 0}
} result] == 0 && $result} then {
return true
} else {
return false
}
}
proc getTestLogStartSentry {} {
if {![info exists ::test_run_id]} then {
set ::test_run_id [getNewTestRunId]
}
return [appendArgs \
"**** START OF TEST LOG \"" $::test_run_id "\" ****\n"]
}
proc extractTestRunIdFromLogStartSentry { sentry } {
set prefix {^\*\*\*\* START OF TEST LOG "}
set suffix {" \*\*\*\*\n$}
set pattern(1) [appendArgs $prefix {([0-9A-F]{56})} $suffix]; # Tcl
if {[regexp -- $pattern(1) $sentry dummy result]} then {
return $result
}
set pattern(2) [appendArgs $prefix {([0-9A-F]{64})} $suffix]; # Eagle
if {[regexp -- $pattern(2) $sentry dummy result]} then {
return $result
}
return <none>
}
proc doesTestLogHaveStartSentry {} {
set fileName [getTestLog]
if {[string length $fileName] > 0} then {
if {[doesTestLogFileExist $fileName]} then {
set sentry [string trim [getTestLogStartSentry]]
if {[string length $sentry] > 0} then {
set data [readFile $fileName]
if {[string first $sentry $data] != -1} then {
return true
}
}
}
}
return false
}
proc didTestLogHaveStartSentry { sentry varName } {
if {[info exists ::test_log_sentry]} then {
if {$::test_log_sentry ne $sentry} then {
upvar 1 $varName error
set error [appendArgs \
"---- test log start sentry mismatch error, was \"" \
[extractTestRunIdFromLogStartSentry $::test_log_sentry] \
"\", now \"" [extractTestRunIdFromLogStartSentry $sentry] \
\"\n]
}
return true
} else {
return false
}
}
proc setTestLogStartSentry { sentry varName } {
upvar 1 $varName result
if {[info exists ::test_log_sentry]} then {
set result [appendArgs \
"---- test log start sentry reinitialized to \"" \
[extractTestRunIdFromLogStartSentry $sentry] \
"\", was \"" [extractTestRunIdFromLogStartSentry \
$::test_log_sentry] \"\n]
} else {
set result [appendArgs \
"---- test log start sentry initialized to \"" \
[extractTestRunIdFromLogStartSentry $sentry] \
\"\n]
}
set ::test_log_sentry $sentry
}
proc tlog { string } {
#
# NOTE: If a test log file was configured, use it; otherwise, ignore the
# message.
#
set fileName [getTestLog]
if {[string length $fileName] > 0} then {
#
# NOTE: Check for any queued test log data that needs to be sent to the
# log file prior to sending the current string.
#
if {[info exists ::test_log_queue]} then {
#
# NOTE: Process each queued test log entry, in order, sending them to
# the test log file (as long as they are not empty strings).
# Each entry is removed from the queue after it is sent to the
# test log file.
#
foreach entry [lsort -integer [array names ::test_log_queue]] {
set newString $::test_log_queue($entry)
if {[string length $newString] > 0} then {
if {![doesTestLogFileExist $fileName]} then {
set sentry [getTestLogStartSentry]
if {[string length $sentry] > 0} then {
#
# BUGFIX: At this point, there should not be any record of a
# previously used test log sentry. If there is, do
# not append a test log sentry again because the test
# log file may have been deleted and we need to make
# sure the test log is not considered as "complete".
#
if {[didTestLogHaveStartSentry $sentry sentryError]} then {
if {[info exists sentryError]} then {
appendSharedLogFile $fileName $sentryError
}
} else {
setTestLogStartSentry $sentry sentryResult
appendSharedLogFile $fileName $sentry
if {[info exists sentryResult]} then {
appendSharedLogFile $fileName $sentryResult
}
}
}
}
appendSharedLogFile $fileName $newString
}
unset ::test_log_queue($entry)
}
#
# NOTE: If all entries in the test log queue were just processed,
# unset the entire array now.
#
if {[array size test_log_queue] == 0} then {
unset ::test_log_queue
}
}
#
# NOTE: If an empty string is supplied by the caller, do nothing.
#
if {[string length $string] > 0} then {
if {![doesTestLogFileExist $fileName]} then {
set sentry [getTestLogStartSentry]
if {[string length $sentry] > 0} then {
#
# BUGFIX: At this point, there should not be any record of a
# previously used test log sentry. If there is, do
# not append a test log sentry again because the test
# log file may have been deleted and we need to make
# sure the test log is not considered as "complete".
#
if {[didTestLogHaveStartSentry $sentry sentryError]} then {
if {[info exists sentryError]} then {
appendSharedLogFile $fileName $sentryError
}
} else {
setTestLogStartSentry $sentry sentryResult
appendSharedLogFile $fileName $sentry
if {[info exists sentryResult]} then {
appendSharedLogFile $fileName $sentryResult
}
}
}
}
appendSharedLogFile $fileName $string
}
}
}
proc getSoftwareRegistryKey { wow64 } {
if {$wow64 && [info exists ::tcl_platform(machine)] && [lsearch -exact \
[list ia64 amd64 arm64] $::tcl_platform(machine)] != -1} then {
#
# NOTE: Return the WoW64 registry key name because we are running on a
# 64-bit operating system and the caller specifically requested
# the WoW64 registry key name.
#
return Software\\Wow6432Node
} else {
#
# NOTE: Return the native registry key name because we are either not
# running on a 64-bit operating system or the caller wants the
# native registry key name (i.e. not the WoW64 registry key name).
#
return Software
}
}
proc haveConstraint { name } {
if {[isEagle]} then {
return [expr {
[info exists ::eagle_tests(Constraints)] && \
[lsearch -exact $::eagle_tests(Constraints) $name] != -1}]
} else {
return [expr {
[info exists ::tcltest::testConstraints($name)] && \
$::tcltest::testConstraints($name)}]
}
}
proc addConstraint { name {value 1} } {
if {[isEagle]} then {
if {[info exists ::eagle_tests(Constraints)] && \
[lsearch -exact $::eagle_tests(Constraints) $name] == -1 && \
$value} then {
lappend ::eagle_tests(Constraints) $name
}
} else {
::tcltest::testConstraint $name $value
}
return ""
}
proc haveOrAddConstraint { name {value ""} } {
if {[isEagle]} then {
if {[llength [info level 0]] == 2} then {
return [haveConstraint $name]
}
return [addConstraint $name [expr {bool($value)}]]
} else {
return [::tcltest::testConstraint $name $value]
}
}
proc getConstraints {} {
set result [list]
if {[isEagle]} then {
if {[catch {set ::eagle_tests(Constraints)} constraints] == 0} then {
eval lappend result $constraints
}
} else {
foreach name [array names ::tcltest::testConstraints] {
if {$::tcltest::testConstraints($name)} then {
lappend result $name
}
}
}
return $result
}
proc getCachedConstraints {} {
if {[info exists ::test_constraints] && \
[llength $::test_constraints] > 0} then {
return $::test_constraints
}
return [getConstraints]
}
proc useCachedConstraints {} {
foreach name [getCachedConstraints] {
addConstraint $name
}
}
proc removeConstraint { name } {
if {[isEagle]} then {
if {[info exists ::eagle_tests(Constraints)]} then {
set index [lsearch -exact $::eagle_tests(Constraints) $name]
if {$index != -1} then {
set ::eagle_tests(Constraints) [lreplace \
$::eagle_tests(Constraints) $index $index]
}
}
} else {
if {[info exists ::tcltest::testConstraints($name)]} then {
unset ::tcltest::testConstraints($name)
}
}
return ""
}
proc fixConstraints { constraints } {
set result [string trim $constraints]
if {[string length $result] > 0} then {
#
# HACK: Fixup for the semi-magical expression (via [expr]) test
# constraint syntax supported by the Tcltest package and not
# by the Eagle.Test package. This needs to happen for Tcl
# in test constraints that contain any characters that are
# not alphanumeric, not a period, and not a colon (e.g. in
# this case, the exclamation point); however, it should only
# be required when the number of test constraints is greater
# than one.
#
if {![isEagle]} then {
if {[string first ! $result] != -1} then {
#
# HACK: All of our test constraints assume they are
# "logically and-ed" together.
#
set result [join [split $result] " && "]
}
}
}
return $result
}
proc isCorePublicKeyToken { publicKeyToken } {
#
# HACK: This list of "well-known" public key tokens is hard-coded.
#
set publicKeyTokens [list \
29c6297630be05eb 1e22ec67879739a2 358030063a832bc3]
if {[isEagle]} then {
set expr {$publicKeyToken in $publicKeyTokens}
if {[expr $expr]} then {
return true
}
} else {
if {[lsearch -exact $publicKeyTokens $publicKeyToken] != -1} then {
return true
}
}
return false
}
proc fixTimingConstraints { constraints } {
#
# HACK: In Eagle, when the right test constraint is present, *any* tests
# where PASSED / FAILED results can vary non-deterministically due
# to timing issues (e.g. performance) are forbidden from causing
# the overall test run to fail.
#
if {[isEagle]} then {
if {[info exists ::no(failTimingTests)] || \
[haveConstraint officialStableReleaseInProgress]} then {
return [fixConstraints [concat $constraints [list fail.false]]]
} else {
return [fixConstraints $constraints]
}
} else {
return [fixConstraints $constraints]
}
}
proc testDebugBreak {} {
if {[isEagle]} then {
#
# NOTE: In Eagle, simply break into the interactive loop using the
# integrated script debugger.
#
debug break
} else {
#
# NOTE: In native Tcl, attempt to use the TclPro Debugger interface.
# This requires that the TclPro Debugger interface package be
# present somewhere along the auto-path.
#
package require tcldebugger_attach; debugger_init; debugger_break
}
}
proc testArrayGet { varName {integer false} } {
#
# NOTE: Returns the results of [array get] in a well-defined order.
#
if {[string length $varName] == 0} then {
return [list]
}
#
# NOTE: Refer to the array in the context of the caller.
#
upvar 1 $varName array
#
# NOTE: Build the command that will sort the array names into order.
#
set command [list lsort]
if {$integer} then {lappend command -integer}
lappend command [array names array]
set result [list]
foreach name [eval $command] {
lappend result $name $array($name)
}
return $result
}
proc testArrayGet2 { varName {pattern ""} {integer false} } {
#
# NOTE: Returns the results of [array get] in a well-defined order.
#
if {[string length $varName] == 0} then {
return [list]
}
#
# NOTE: Refer to the array in the context of the caller.
#
upvar 1 $varName array
#
# NOTE: Build the command that will sort the array names into order.
#
set command [list lsort]
if {$integer} then {lappend command -integer}
#
# NOTE: If there is a pattern, use it; otherwise, all elements are
# returned.
#
if {[string length $pattern] > 0} then {
lappend command [array names array $pattern]
} else {
lappend command [array names array]
}
set result [list]
foreach name [eval $command] {
lappend result $name $array($name)
}
return $result
}
proc testResultGet { script } {
set code [catch {uplevel 1 $script} result]
return [expr {$code == 0 ? $result : "<error>"}]
}
proc testValueGet { varName {integer false} } {
#
# NOTE: Returns the results of [array get] in a well-defined order
# -OR- the value of the scalar variable.
#
if {[string length $varName] == 0} then {
return [list]
}
#
# NOTE: Is the specified variable (in the context of the caller) an
# array?
#
if {[uplevel 1 [list array exists $varName]]} then {
#
# NOTE: Refer to the array in the context of the caller.
#
upvar 1 $varName array
#
# NOTE: Build the command that will sort the array names into order.
#
set command [list lsort]
if {$integer} then {lappend command -integer}
lappend command [array names array]
set result [list]
foreach name [eval $command] {
lappend result $name $array($name)
}
} else {
#
# NOTE: Grab the value of the scalar variable in the context of the
# caller and then return both the name and the value.
#
set varValue [uplevel 1 [list set $varName]]
set result [list $varValue]
}
return $result
}
proc getFirstLineOfError { error } {
set error [string map [list \r\n \n] $error]
set index [string first \n $error]
if {$index != -1} then {
incr index -1
if {$index > 0} then {
return [string range $error 0 $index]
}
}
return $error
}
proc calculateBogoCops { {milliseconds 2000} {legacy false} } {
#
# NOTE: Verify that the number of milliseconds requested is greater
# than zero.
#
if {$milliseconds <= 0} then {
unset -nocomplain ::test_suite_running
error "number of milliseconds must be greater than zero"
}
#
# HACK: Different techniques are used to calculate the performance of
# the machine for Tcl and Eagle.
#
if {!$legacy && [isEagle]} then {
#
# BUGBUG: Tcl 8.4 does not like this expression (and Tcl tries to
# compile it even though it will only actually ever be
# evaluated in Eagle).
#
set expr {[catch {
string first -timeout [time nop -1 ---]
} timeout] in [list 0 2] && $timeout != -1}
#
# HACK: Attempt to determine if the "-timeout" option for [time] is
# available. If so, use it.
#
if {[expr $expr]} then {
set code [catch {
#
# NOTE: This is the most robust method, i.e. use the "-timeout"
# option to the [time] command.
#
set before [info cmdcount]
catch {time {nop} -1 -timeout $milliseconds}; # internal loop.
set after [info cmdcount]
#
# HACK: Mono has a bug that results in excessive trailing zeros
# here (Mono bug #655780).
#
if {[isMono]} then {
expr {double(($after - $before) / ($milliseconds / 1000.0))}
} else {
expr {($after - $before) / ($milliseconds / 1000.0)}
}
} result]
#
# NOTE: If we failed above, return an obviously invalid result
# instead.
#
if {$code == 0} then {
return $result
} else {
return 0
}
} else {
#
# HACK: This calculation method (i.e. using [after] to cancel the
# [time] command after the specified number of milliseconds)
# is no longer necessary as of Beta 45; however, it will be
# retained for backward compatibility with previous releases
# solely for the purpose of running comparative benchmarks.
#
# NOTE: Save the current readiness limit for later restoration
# and then set the current readiness limit to always check
# the interpreter readiness (default). If this was not
# done, the [interp cancel] command in this procedure may
# have no effect, which could cause this procedure to run
# forever.
#
set readylimit [interp readylimit {}]
interp readylimit {} 0
try {
#
# NOTE: Save the current background error handler for later
# restoration and then reset the current background
# error handler to nothing.
#
set bgerror [interp bgerror {}]
interp bgerror {} ""
try {
#
# NOTE: Save the current [after] flags for later restoration
# and then reset them to process events immediately.
#
set flags [after flags]
after flags =Immediate
try {
set code [catch {
#
# NOTE: First, make sure that the [after] event queue
# for the interpreter is totally empty.
#
catch {foreach id [after info] {after cancel $id}}
#
# NOTE: Schedule the event to cancel the script we are
# about to evaluate, capturing the name so we can
# cancel it later, if necessary.
#
set event [after $milliseconds [list interp cancel]]
#
# HACK: There is a potential "race condition" here. If the
# specified number of milliseconds elapses before (or
# after) entering the [catch] script block (below)
# then the resulting script cancellation error will
# not be caught and we will be unable to return the
# correct result to the caller.
#
set before [info cmdcount]
catch {time {nop} -1}; # uses the [time] internal busy loop.
set after [info cmdcount]
#
# HACK: Mono has a bug that results in excessive trailing
# zeros here (Mono bug #655780).
#
if {[isMono]} then {
expr {double(($after - $before) / ($milliseconds / 1000.0))}
} else {
expr {($after - $before) / ($milliseconds / 1000.0)}
}
} result]
#
# NOTE: If we failed due to the race condition explained
# above, return an obviously invalid result instead.
#
if {$code == 0} then {
return $result
} else {
return 0
}
} finally {
if {[info exists event]} then {
catch {after cancel $event}
}
after flags [appendArgs = $flags]
}
} finally {
interp bgerror {} $bgerror
}
} finally {
interp readylimit {} $readylimit
}
}
} else {
#
# NOTE: Record the initial Tcl command count.
#
set before [info cmdcount]
#
# NOTE: Calculate how many whole seconds we need to spin for.
#
set seconds [expr {$milliseconds / 1000}]
#
# NOTE: Calculate the starting and ending values of [clock seconds].
#
set now [clock seconds]
set start $now; set stop [expr {$now + $seconds}]
#
# NOTE: Do nothing for X seconds (i.e. except call [clock seconds]).
#
while {$start <= $now && $now < $stop} {set now [clock seconds]}
#
# NOTE: Record the final Tcl command count.
#
set after [info cmdcount]
#
# NOTE: Calculate approximately how many Tcl commands per second were
# executed during the timed loop (above). Due to various things,
# including overhead associated with [clock seconds], this number
# is not as accurate as the one for Eagle; however, it's generally
# good enough.
#
expr {($after - $before) / double($seconds)}
}
}
proc calculateRelativePerformance { type value } {
#
# NOTE: Adjust the expected performance number based on the
# relative performance of this machine, if available.
#
if {[info exists ::test_base_cops] && [info exists ::test_cops]} then {
#
# NOTE: Calibrate the expected performance numbers based
# on the ratio of the baseline performace to the
# current performance.
#
switch -exact -- $type {
elapsed {
if {$::test_cops != 0} then {
return [expr {double($value) * \
($::test_base_cops / $::test_cops)}]
}
}
iterations {
if {$::test_base_cops != 0} then {
return [expr {double($value) * \
($::test_cops / $::test_base_cops)}]
}
}
}
}
return $value
}
proc formatTimeStamp { seconds {gmt false} } {
if {[isEagle]} then {
return [clock format $seconds -gmt $gmt -iso -isotimezone]
} else {
return [clock format $seconds -gmt $gmt -format "%Y-%m-%dT%H:%M:%S %Z"]
}
}
proc formatElapsedTime { seconds } {
if {[isEagle] && [llength [info commands object]] > 0} then {
#
# NOTE: Create a TimeSpan instance based on the number of whole
# seconds.
#
set timeSpan [object invoke -create -alias TimeSpan FromSeconds \
$seconds]
#
# NOTE: Return the number of seconds and a human readable string
# representing the TimeSpan instance created based on that
# same number of seconds.
#
return [appendArgs $seconds " seconds (" [$timeSpan ToString] \
" elapsed time)"]
} else {
#
# NOTE: Unfortunately, there is no built-in native Tcl command
# that can correctly format an elapsed time; therefore,
# just return the number of whole seconds.
#
return [appendArgs $seconds " seconds"]
}
}
proc sourceIfValid { type fileName } {
if {[string length $fileName] > 0} then {
if {[file exists $fileName]} then {
tputs $::test_channel [appendArgs \
"---- evaluating " $type " file: \"" $fileName \"\n]
if {[catch {uplevel 1 [list source $fileName]} error]} then {
tputs $::test_channel [appendArgs \
"---- error during " $type " file: " $error \n]
#
# NOTE: The error has been logged, now re-throw it.
#
unset -nocomplain ::test_suite_running
error $error $::errorInfo $::errorCode
}
} else {
tputs $::test_channel [appendArgs \
"---- skipped " $type " file: \"" $fileName \
"\", it does not exist\n"]
}
}
}
proc processTestArguments { varName strict args } {
#
# NOTE: Initially, there are no unknown (i.e. unprocessed) arguments.
#
set result [list]
#
# NOTE: We are going to place the configured options in the variable
# identified by the name provided by the caller.
#
if {[string length $varName] > 0} then {
upvar 1 $varName array
}
#
# TODO: Add more support for standard "tcltest" options here.
#
set options [list \
-breakOnLeak -configuration -constraints -exitOnComplete \
-file -logFile -logId -logPath -machine -match -namePrefix \
-no -notFile -platform -postTest -preTest -postWait -preWait \
-randomOrder -skip -startFile -stopFile -stopOnFailure \
-stopOnLeak -suffix -suite -tclsh -threshold -uncountedLeaks \
-verbose]
set length [llength $args]
for {set index 0} {$index < $length} {incr index} {
#
# NOTE: Grab the current list element, which should be the name of
# the test option.
#
set name [lindex $args $index]
#
# NOTE: Use the [tqputs] command here just in case the test log file
# has not been setup yet (i.e. by default, this procedure is
# almost always called by the test prologue file prior to the
# test log file having been setup and we do not want to just
# lose this output).
#
if {[lsearch -exact $options $name] != -1} then {
#
# NOTE: Is there another list element available for the value? If
# not, this is not a valid test option.
#
if {$index + 1 < $length} then {
incr index; set value [lindex $args $index]
set array($name) $value
tqputs $::test_channel [appendArgs \
"---- overrode test option \"" $name "\" with value \"" \
$value \"\n]
} else {
tqputs $::test_channel [appendArgs \
"---- no value for test option \"" $name "\", ignored\n"]
}
} elseif {[string index $name 0] eq "-"} then {
#
# NOTE: Is there another list element available for the value? If
# not, it does not conform to the standard command line name
# and value pattern.
#
if {$index + 1 < $length} then {
incr index; set value [lindex $args $index]
if {!$strict && [lsearch -exact $options $value] != -1} then {
incr index -1; # HACK: Resynchronize with valid test option.
lappend result [list $name]
tqputs $::test_channel [appendArgs \
"---- no value for unknown test option \"" $name \
"\", ignored, backing up one for test option \"" \
$value \"...\n]
} else {
lappend result [list $name $value]
tqputs $::test_channel [appendArgs \
"---- unknown test option \"" $name "\" with value \"" \
$value "\", ignored\n"]
}
} else {
lappend result [list $name]
tqputs $::test_channel [appendArgs \
"---- no value for unknown test option \"" $name \
"\", ignored\n"]
}
} else {
#
# NOTE: Is there another list element available for the value? If
# not, it does not conform to the standard command line name
# and value pattern.
#
if {$index + 1 < $length} then {
incr index; set value [lindex $args $index]
if {!$strict && [lsearch -exact $options $value] != -1} then {
incr index -1; # HACK: Resynchronize with valid test argument.
lappend result [list $name]
tqputs $::test_channel [appendArgs \
"---- no value for unknown argument \"" $name \
"\", ignored, backing up one for test option \"" \
$value \"...\n]
} else {
lappend result [list $name $value]
tqputs $::test_channel [appendArgs \
"---- unknown argument \"" $name "\" with value \"" \
$value "\", ignored\n"]
}
} else {
#
# NOTE: This is not an option of *any* kind that we know about.
# Ignore it and issue a warning.
#
lappend result [list $name]
tqputs $::test_channel [appendArgs \
"---- unknown argument \"" $name "\", ignored\n"]
}
}
}
#
# NOTE: Now, attempt to flush the test log queue, if available.
#
tlog ""
#
# NOTE: Return the nested list of unknown arguments, formatted as
# name/value pairs, to the caller.
#
return $result
}
proc getTclShellFileName { automatic kits machine } {
#
# NOTE: Start out with an empty list of candiate Tcl shells.
#
set shells [list]
#
# NOTE: Figure out the environment variables to be checked. If
# there was a machine specified, it will be used to check
# for machine-specific Tcl shells.
#
set names [list]
foreach name [list Eagle_Tcl_Shell Tcl_Shell EAGLE_TCLSH TCLSH] {
if {[string length $machine] > 0} then {
set platform [machineToPlatform $machine true]
if {[string length $platform] > 0} then {
lappend names [appendArgs $name _ $platform]
}
set platform [machineToPlatform $machine false]
if {[string length $platform] > 0} then {
lappend names [appendArgs $name _ $platform]
}
lappend names [appendArgs $name _ $machine]
}
lappend names $name
}
#
# NOTE: Check all environment variables (we know about) that
# may contain the path where the Tcl shell is located.
#
foreach name $names {
#
# NOTE: Grab the value of the environment variable. This
# will be an empty string if it was not set.
#
set value [getEnvironmentVariable $name]
#
# TODO: Possibly add a check if the file actually exists
# here.
#
if {[string length $value] > 0} then {
#
# NOTE: *EXTERNAL* Use verbatim, no normalization.
#
if {$automatic && [isEagle]} then {
#
# NOTE: In automatic mode, the environment variable
# value simply represents another candidate
# Tcl shell (i.e. it does not halt the search
# for other candidate Tcl shells).
#
lappend shells $value
} else {
#
# NOTE: In manual mode, the environment variable
# value represents an "override" and halts
# the search for other candidate Tcl shells.
#
return $value
}
}
}
#
# NOTE: The automatic Tcl shell detection is only available when
# running in Eagle.
#
if {[isEagle]} then {
#
# NOTE: Attempt to check for the "best" available dynamically
# loadable Tcl library and then attempt to use its
# "associated" Tcl shell. A very similar block of code
# is also used by the [checkForTclInstalls] procedure
# in the constraints package.
#
if {[catch {tcl select -architecture} tcl] == 0} then {
#
# NOTE: Should we also consider TclKit shells? If so, a bit
# more handling is required.
#
if {$kits} then {
#
# NOTE: Did we find one? Attempt to grab the patch
# level field from the returned dictionary value.
#
set dotPatchLevel [getDictionaryValue $tcl patchLevel]
#
# NOTE: Verify that the patch level we found is valid
# and that it conforms to the pattern we expect.
#
if {[string length $dotPatchLevel] > 0 && \
[regexp -- {^\d+\.\d+\.\d+$} $dotPatchLevel]} then {
#
# NOTE: Build the candidate TclKit shell executable file
# name with the dot-separated patch level. This is
# the common naming scheme on Unix.
#
set dotShell [appendArgs tclkit- $dotPatchLevel]
#
# NOTE: Build the candidate TclKit shell executable file
# name with the patch level, removing the dot. This
# is the common naming scheme on Windows.
#
set shell [appendArgs \
tclkit- [string map [list . ""] $dotPatchLevel]]
#
# NOTE: Always favor the TclKit shell executable file
# naming scheme for the current operating system
# first.
#
if {[isWindows]} then {
lappend shells $shell
lappend shells $dotShell
} else {
lappend shells $dotShell
lappend shells $shell
}
}
}
#
# NOTE: Did we find one? Attempt to grab the version
# field from the returned dictionary value.
#
set dotVersion [getDictionaryValue $tcl version]
#
# NOTE: Verify that the version we found is valid and that
# it conforms to the pattern we expect.
#
if {[string length $dotVersion] > 0 && \
[regexp -- {^\d+\.\d+$} $dotVersion]} then {
#
# NOTE: Gather the list of candidate Tcl shells to check
# using the range of versions we are interested in,
# starting with the "best" available version and
# ending with the absolute minimum version supported
# by the Eagle core library. A very similar block
# of code is also used by the [checkForTclShell]
# procedure in the constraints package.
#
foreach version [lsort -real -decreasing [tcl \
versionrange -maximumversion $dotVersion]] {
#
# NOTE: Build the candidate Tcl shell executable file name
# with the dot-separated version. This is the common
# naming scheme on Unix.
#
set dotShell [appendArgs tclsh $version]
#
# NOTE: Build the candidate Tcl shell executable file name
# with the version, removing the dot. This is the
# common naming scheme on Windows.
#
set shell [appendArgs tclsh [string map [list . ""] $version]]
#
# NOTE: Always favor the Tcl shell executable file naming
# scheme for the current operating system first.
#
if {[isWindows]} then {
lappend shells $shell
lappend shells $dotShell
} else {
lappend shells $dotShell
lappend shells $shell
}
}
}
}
#
# NOTE: Check each candidate Tcl shell and query its fully
# qualified path from it. If it cannot be executed,
# we know that candidate Tcl shell is not available.
#
if {![info exists ::no(getTclExecutableForTclShell)]} then {
foreach shell $shells {
if {[catch {
getTclExecutableForTclShell $shell [getTclShellVerbosity]
} executable] == 0 && $executable ne "error" && \
![string match "error: *" $executable]} then {
#
# NOTE: It looks like this Tcl shell is available.
# Return the fully qualified path to it now.
#
return $executable
}
}
}
}
#
# NOTE: Return the fallback default.
#
return tclsh
}
proc getTemporaryPath { {usable true} } {
#
# NOTE: Build the list of "temporary directory" override
# environment variables to check.
#
set names [list]
foreach name [list \
EAGLE_TEST_TEMP EAGLE_TEMP XDG_RUNTIME_DIR TEMP TMP] {
#
# NOTE: Make sure we handle all the reasonable "cases" of
# the environment variable names.
#
lappend names [string toupper $name] [string tolower $name] \
[string totitle $name]
}
#
# NOTE: Check if we can use any of the environment variables.
#
foreach name $names {
set value [getEnvironmentVariable $name]
#
# NOTE: First, make sure the environment variable was actually
# set to something.
#
if {[string length $value] > 0} then {
#
# NOTE: Next, when the "usable" argument is non-zero, attempt
# to make sure the returned temporary path is actually
# an existing directory, writable by us.
#
if {$usable} then {
if {[file isdirectory $value] && [file writable $value]} then {
return [file normalize $value]
}
} else {
return [file normalize $value]
}
}
}
if {[isEagle] && [llength [info commands object]] > 0} then {
#
# NOTE: Eagle fallback, use whatever is reported by the
# underlying framework and/or operating system.
#
return [file normalize [object invoke System.IO.Path GetTempPath]]
} else {
#
# NOTE: Tcl fallback, *assume* that we can use the
# directory where the executable is running for
# temporary storage.
#
return [file normalize [file dirname [info nameofexecutable]]]
}
}
proc getTemporaryFileName { {seconds 5} } {
if {[isEagle]} then {
return [file tempname]
} else {
set path [getTemporaryPath]
set now [clock seconds]
set start $now; set stop [expr {$now + $seconds}]
while {$start <= $now && $now < $stop} {
binary scan [binary format d* [expr {rand()}]] h* random
set fileNameOnly [appendArgs \
tmp [string index $random 0] [string index $random 1] \
[string index $random end-1] [string index $random end] \
.tmp]
set fileName [file join $path $fileNameOnly]
if {![file exists $fileName]} then {
return $fileName
}
set now [clock seconds]
}
error "cannot generate temporary file name"
}
}
proc getFiles { directory pattern } {
if {[isEagle]} then {
set result [list]
if {[file exists $directory] && [file isdirectory $directory]} then {
foreach fileName [lsort -dictionary [file list $directory $pattern]] {
if {[file isfile $fileName] && [file readable $fileName]} then {
lappend result $fileName
}
}
}
return $result
} else {
return [lsort -dictionary [glob -directory $directory -types \
{f r} -nocomplain -- $pattern]]
}
}
proc getTestFiles { directories matchFilePatterns skipFilePatterns } {
set result [list]
foreach directory $directories {
set matchFileNames [list]
foreach pattern $matchFilePatterns {
eval lappend matchFileNames [getFiles $directory $pattern]
}
set skipFileNames [list]
foreach pattern $skipFilePatterns {
eval lappend skipFileNames [getFiles $directory $pattern]
}
foreach fileName $matchFileNames {
if {[lsearch -exact $skipFileNames $fileName] == -1} then {
lappend result $fileName
}
}
}
return $result
}
proc getTestRunId {} {
return [expr {[info exists ::test_run_id] ? $::test_run_id : ""}]
}
proc getNewTestRunId {} {
#
# HACK: Yes, this is a bit ugly; however, it creates a nice unique
# identifier to represent the test run, which makes analyzing
# the test log files a lot easier.
#
if {[isEagle]} then {
#
# BUGBUG: Tcl 8.4 does not like this expression (and Tcl tries to
# compile it even though it will only actually ever be
# evaluated in Eagle).
#
set expr {random()}
#
# NOTE: Include the host name to make the result more unique in both
# time and space. Also, hash the entire constructed string.
#
if {![isMono]} then {
#
# NOTE: When running on the .NET Framework, we can simply use the
# [string format] command.
#
return [hash normal sha256 [string format \
"{0}{1:X8}{2:X8}{3:X16}{4:X16}{5:X16}" [info host] [pid] \
[info tid] [clock now] [clock clicks] [expr $expr]]]
} else {
#
# HACK: Mono does not currently support calling the String.Format
# overload that takes a variable number of arguments via
# reflection (Mono bug #636939). Also, strip any leading
# minus signs for cleanliness.
#
return [hash normal sha256 [appendArgs [info host] [string \
trimleft [pid] -] [string trimleft [info tid] -] [string \
trimleft [clock now] -] [string trimleft [clock clicks] -] \
[string trimleft [expr $expr] -]]]
}
} else {
#
# NOTE: Generate a random number using [expr] and then convert it
# to a 64-bit integer.
#
binary scan [binary format d* [expr {rand()}]] w* random
#
# NOTE: Convert the host name to a hexadecimal string and include
# it in the result in an attempt to make it more unique in
# both time and space.
#
binary scan [info host] c* host
set host [eval [list format [string repeat %X [llength $host]]] $host]
#
# NOTE: Build the final result with the [format] command, converting
# all the pieces to hexadecimal (except the host, which is
# already hexadecimal).
#
set pid [pid]; set seconds [clock seconds]; set clicks [clock clicks]
return [appendArgs \
$host [format [appendArgs % [getLengthModifier $pid] X% \
[getLengthModifier $seconds] X% [getLengthModifier $clicks] X% \
[getLengthModifier $random] X] $pid $seconds $clicks $random]]
}
}
proc getDefaultTestLogPath { executable } {
#
# NOTE: By default, use the configured temporary directory for
# test log files unless we are forbidden from doing so.
#
if {![info exists ::no(temporaryTestLog)]} then {
return [getTemporaryPath]
} else {
#
# HACK: It seems that .NET Core considers itself to be the
# executable-of-record for the process; in that case,
# relocate the log file to be nearer the assemblies.
#
if {[isEagle] && [isDotNetCore]} then {
return [info binary]
} else {
return [file dirname $executable]
}
}
}
proc getTestLogPath {} {
return [expr {[info exists ::test_log_path] ? $test_log_path : ""}]
}
proc getTestLogId {} {
return [expr {[info exists ::test_log_id] ? \
[append result . $::test_log_id] : ""}]
}
proc getDefaultTestLog {} {
set executable [info nameofexecutable]
if {[info exists ::test_log_path]} then {
set path $::test_log_path
} else {
set path [getDefaultTestLogPath $executable]
}
return [file normalize [file join $path [appendArgs \
[file tail $executable] [getTestLogId] .test. [pid] .log]]]
}
proc getTestLog {} {
return [expr {[info exists ::test_log] ? $::test_log : ""}]
}
proc getLastTestLog {} {
#
# NOTE: Use the configured log file name -OR- what the configured
# log file name would be, by default, if it actually existed.
#
if {[info exists ::test_log]} then {
set logFileName $::test_log
} else {
set logFileName [getDefaultTestLog]
}
set logFileName [file normalize $logFileName]
set logTime [expr {[file exists $logFileName] ? \
[file mtime $logFileName] : 0}]
#
# NOTE: Make the log file name into a pattern we can use to find
# the related log files.
#
if {[regsub -- {\.\d+\.} $logFileName {.*.} pattern]} then {
set lastLogFile [list]
foreach fileName [findFiles $pattern] {
#
# NOTE: Skip the current test log file, if found.
#
if {[isSameFileName $fileName $logFileName]} then {
continue
}
#
# NOTE: When was this log file last modified?
#
set time [file mtime $fileName]
#
# NOTE: Check if there has been no log file seen -OR- this
# log file has the latest modified time seen.
#
if {[llength $lastLogFile] == 0 || \
$time > [lindex $lastLogFile 0]} then {
#
# NOTE: This is now the latest log file seen.
#
set lastLogFile [list $time $fileName]
}
}
#
# NOTE: Either return the last log file seen, if any -OR- the
# configured log file, if it actually exists.
#
if {[llength $lastLogFile] > 0} then {
return [lindex $lastLogFile 1]
} elseif {$logTime != 0} then {
return $logFileName
}
}
return ""
}
proc getTestSuite {} {
#
# NOTE: Determine the effective test suite name and return it. If the
# test suite name cannot be determined, return the default based
# on whether we are running in Eagle or native Tcl.
#
if {[info exists ::test_flags(-suite)] && \
[string length $::test_flags(-suite)] > 0} then {
#
# NOTE: The test suite name has been manually overridden via the test
# flags; therefore, use it.
#
return $::test_flags(-suite)
} elseif {[info exists ::test_suite]} then {
#
# NOTE: Use the test suite name. The default value is set by the test
# suite prologue; however, this may have been overridden.
#
return $::test_suite
} elseif {[isEagle]} then {
#
# NOTE: Use the default test suite name for Eagle.
#
return "Eagle Test Suite for Eagle"
} else {
#
# NOTE: Use the default test suite name for native Tcl.
#
return "Eagle Test Suite for Tcl"
}
}
proc getTestSuiteFullName {} {
if {[isEagle]} then {
set fileName [probeForScriptFileName [list \
[file join * prologue.eagle] [file join * epilogue.eagle] \
[file join * Test1.0 *]]]
} else {
set fileName ""
}
if {[string length $fileName] == 0} then {
if {[info exists ::test_suite_file]} then {
set fileName $::test_suite_file
}
}
if {[string length $fileName] == 0} then {
set fileName [info script]
}
if {[string length $fileName] == 0} then {
set fileName <none>
}
set suiteName [getTestSuite]
if {[string length $suiteName] == 0} then {
set suiteName <none>
}
return [appendArgs $fileName " (" $suiteName )]
}
proc getTestMachine {} {
#
# NOTE: Determine the effective test machine and return it. If the
# test machine cannot be determined, return an empty string.
#
if {[info exists ::test_flags(-machine)] && \
[string length $::test_flags(-machine)] > 0} then {
#
# NOTE: The test machine has been manually overridden via the test
# flags; therefore, use it.
#
return $::test_flags(-machine)
} elseif {[info exists ::test_machine]} then {
#
# NOTE: Use the test machine. The default value is set by the test
# suite prologue; however, this may have been overridden.
#
return $::test_machine
} elseif {[info exists ::tcl_platform(machine)]} then {
#
# NOTE: Use the build machine of Eagle itself.
#
return $::tcl_platform(machine)
} else {
#
# NOTE: We are missing the machine, return nothing.
#
return ""
}
}
proc getTestPlatform { {architecture false} } {
#
# NOTE: Determine the effective test platform and return it. If the
# test platform cannot be determined, return an empty string.
#
if {[info exists ::test_flags(-platform)] && \
[string length $::test_flags(-platform)] > 0} then {
#
# NOTE: The test platform has been manually overridden via the test
# flags; therefore, use it.
#
return $::test_flags(-platform)
} elseif {[info exists ::test_platform]} then {
#
# NOTE: Use the test platform. The default value is set by the test
# suite prologue; however, this may have been overridden.
#
return $::test_platform
} else {
set machine [getTestMachine]
if {[string length $machine] > 0} then {
#
# NOTE: Use the machine architecture to figure out the platform
# and then return it.
#
return [machineToPlatform $machine $architecture]
} else {
#
# NOTE: We are missing the machine and we cannot figure out the
# platform without it; therefore, return nothing.
#
return ""
}
}
}
proc getTestConfiguration {} {
#
# NOTE: Determine the effective test configuration and return it. If
# the test configuration cannot be determined, return an empty
# string.
#
if {[info exists ::test_flags(-configuration)] && \
[string length $::test_flags(-configuration)] > 0} then {
#
# NOTE: The test configuration has been manually overridden via the
# test flags; therefore, use it.
#
return $::test_flags(-configuration)
} elseif {[info exists ::test_configuration]} then {
#
# NOTE: Use the test configuration. The default value is set by the
# test suite prologue; however, this may have been overridden.
#
return $::test_configuration
} elseif {[info exists ::eagle_platform(configuration)]} then {
#
# NOTE: Use the build configuration of Eagle itself. This value will
# most likely be either "Debug" or "Release".
#
return $::eagle_platform(configuration)
} else {
#
# NOTE: We are missing the configuration, return nothing.
#
return ""
}
}
proc getTestNamePrefix {} {
#
# NOTE: Determine the effective test name prefix and return it. If
# the test name prefix cannot be determined, return an empty
# string.
#
if {[info exists ::test_flags(-namePrefix)] && \
[string length $::test_flags(-namePrefix)] > 0} then {
#
# NOTE: The test name prefix has been manually overridden via the
# test flags; therefore, use it.
#
return $::test_flags(-namePrefix)
} elseif {[info exists ::test_name_prefix] && \
[string length $::test_name_prefix] > 0} then {
#
# NOTE: Use the default test name prefix.
#
return $::test_name_prefix
} else {
#
# NOTE: We are missing the test name prefix, return nothing.
#
return ""
}
}
proc getTestSuffix {} {
#
# NOTE: Determine the effective test suffix and return it. If
# the test suffix cannot be determined, return an empty
# string.
#
if {[info exists ::test_flags(-suffix)] && \
[string length $::test_flags(-suffix)] > 0} then {
#
# NOTE: The test suffix has been manually overridden via the
# test flags; therefore, use it.
#
return $::test_flags(-suffix)
} elseif {[info exists ::test_suffix]} then {
#
# NOTE: Use the test suffix. There is no default value for
# this variable (i.e. by default, it does not exist).
#
return $::test_suffix
} elseif {[info exists ::eagle_platform(text)] && \
[string length $::eagle_platform(text)] > 0} then {
#
# NOTE: Use the build "text" of Eagle itself. This value
# will typically be "NetFx20", "NetFx40", etc. The
# default value of this element is an empty string.
#
return $::eagle_platform(text)
} elseif {[info exists ::eagle_platform(suffix)] && \
[string length $::eagle_platform(suffix)] > 0} then {
#
# NOTE: Use the build suffix of Eagle itself. This value
# will typically be "NetFx20", "NetFx40", etc. The
# default value of this element is an empty string.
#
return $::eagle_platform(suffix)
} else {
#
# NOTE: We are missing the test suffix, return nothing.
#
return ""
}
}
proc getTestUncountedLeaks {} {
if {[info exists ::test_uncounted_leaks] && \
[string length $::test_uncounted_leaks] > 0} then {
return $::test_uncounted_leaks
}
return [list]
}
proc getRuntimeAssemblyName {} {
if {[isEagle]} then {
if {[isDotNetCore]} then {
if {[llength [info commands object]] > 0} then {
#
# HACK: The core runtime assembly (i.e. the one containing
# System.Object, et al) must have already been loaded
# (?), so just abuse the [object load] sub-command to
# return its assembly name.
#
return [lindex [object load System.Private.CoreLib] 0]
} else {
#
# HACK: The [object] command is unavailable, just fake it.
#
return "System.Private.CoreLib, Version=4.0.0.0,\
Culture=neutral, PublicKeyToken=7cec85d7bea7798e"
}
} else {
if {[llength [info commands object]] > 0} then {
#
# HACK: The core runtime assembly (i.e. the one containing
# System.Object, et al) must have already been loaded
# (?), so just abuse the [object load] sub-command to
# return its assembly name.
#
return [lindex [object load mscorlib] 0]
} else {
#
# HACK: The [object] command is unavailable, just fake it.
#
if {[info exists ::eagle_platform(runtimeVersion)] && \
[string index $::eagle_platform(runtimeVersion) 0] >= 4} then {
#
# BUGBUG: Does not handle a major CLR version greater than
# four (4).
#
return "mscorlib, Version=4.0.0.0, Culture=neutral,\
PublicKeyToken=b77a5c561934e089"
} else {
return "mscorlib, Version=2.0.0.0, Culture=neutral,\
PublicKeyToken=b77a5c561934e089"
}
}
}
} else {
#
# HACK: Native Tcl has no runtime assembly name as it is native.
#
return ""
}
}
proc getTestAssemblyName {} {
if {[isEagle]} then {
return [lindex [split [lindex [info assembly] 0] ,] 0]
} else {
return Eagle
}
}
#
# NOTE: This procedure should return non-zero if the [exec] command may be
# used by the specified test package procedure.
#
proc canTestExec { procName } {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(canTestExec)]} then {
return false
}
if {[string length $procName] > 0 && \
[info exists [appendArgs ::no(canTestExec. $procName )]]} then {
return false
}
return true
}
proc testExec { commandName options args } {
set command [list exec]
if {[llength $options] > 0} then {eval lappend command $options}
lappend command -- $commandName
if {[llength $args] > 0} then {eval lappend command $args}
set procName [lindex [info level [info level]] 0]
if {![canTestExec $procName]} then {
tputs $::test_channel [appendArgs "---- skipping command: " $command \n]
error "test use of \[$procName\] has been disabled"
} else {
tputs $::test_channel [appendArgs "---- running command: " $command \n]
return [uplevel 1 $command]
}
}
proc testClrExec { commandName options args } {
set command [list exec]
if {[llength $options] > 0} then {eval lappend command $options}
lappend command --
#
# HACK: Assume that Mono is somewhere along the PATH.
#
if {[isMono]} then {
lappend command mono \
[appendArgs \" [file nativename $commandName] \"]
} else {
#
# HACK: When running on .NET Core, need to insert "dotnet exec"
# command line arguments before command to execute.
#
if {[isDotNetCore]} then {
lappend command dotnet exec \
[appendArgs \" [file nativename $commandName] \"]
} else {
lappend command $commandName
}
}
if {[llength $args] > 0} then {eval lappend command $args}
set procName [lindex [info level [info level]] 0]
if {![canTestExec $procName]} then {
tputs $::test_channel [appendArgs "---- skipping command: " $command \n]
error "test use of \[$procName\] has been disabled"
} else {
tputs $::test_channel [appendArgs "---- running command: " $command \n]
return [uplevel 1 $command]
}
}
proc execTestShell { options args } {
set procName [lindex [info level [info level]] 0]
if {![canTestExec $procName]} then {
tputs $::test_channel [appendArgs \
"---- skipping nested shell: exec " [string trim [appendArgs \
$options " " -- " \"" [info nameofexecutable] "\" " $args]] \n]
error "test use of \[$procName\] has been disabled"
} else {
tputs $::test_channel [appendArgs \
"---- running nested shell: exec " [string trim [appendArgs \
$options " " -- " \"" [info nameofexecutable] "\" " $args]] \n]
return [uplevel 1 execShell [list $options] $args]
}
}
proc isRandomOrder {} {
return [expr {[info exists ::test_random_order] && \
[string is boolean -strict $::test_random_order] && \
$::test_random_order}]
}
proc isBreakOnLeak {} {
return [expr {[info exists ::test_break_on_leak] && \
[string is boolean -strict $::test_break_on_leak] && \
$::test_break_on_leak}]
}
proc isBreakOnDemand {} {
global env
return [expr {[info exists env(isBreakOnDemand)] && \
[string is boolean -strict $env(isBreakOnDemand)] && \
$env(isBreakOnDemand)}]
}
proc isStopOnFailure {} {
return [expr {[info exists ::test_stop_on_failure] && \
[string is boolean -strict $::test_stop_on_failure] && \
$::test_stop_on_failure}]
}
proc isStopOnLeak {} {
return [expr {[info exists ::test_stop_on_leak] && \
[string is boolean -strict $::test_stop_on_leak] && \
$::test_stop_on_leak}]
}
proc isExitOnComplete {} {
return [expr {[info exists ::test_exit_on_complete] && \
[string is boolean -strict $::test_exit_on_complete] && \
$::test_exit_on_complete}]
}
proc returnInfoScript {} {
return [info script]
}
proc runTestPrologue {} {
#
# NOTE: Verify that the global test path variable is available.
#
if {![info exists ::test_path]} then {
error "cannot run test prologue, \"::test_path\" must be set"
}
#
# NOTE: Reset the primary test suite file name to our caller.
#
if {![info exists ::no(testSuiteFile)]} then {
set ::test_suite_file [info script]
}
#
# HACK: We do not want to force every third-party test suite
# to come up with a half-baked solution to finding its
# own files.
#
if {![info exists ::no(prologue.eagle)] && ![info exists ::path]} then {
set ::path [file normalize [file dirname [info script]]]
}
#
# NOTE: Evaluate the standard test prologue in the context of
# the caller.
#
uplevel 1 [list source [file join $::test_path prologue.eagle]]
}
proc runTestEpilogue {} {
#
# NOTE: Verify that the global test path variable is available.
#
if {![info exists ::test_path]} then {
error "cannot run test epilogue, \"::test_path\" must be set"
}
#
# NOTE: Reset the primary test suite file name to our caller.
#
if {![info exists ::no(testSuiteFile)]} then {
set ::test_suite_file [info script]
}
#
# NOTE: Evaluate the standard test epilogue in the context of
# the caller.
#
uplevel 1 [list source [file join $::test_path epilogue.eagle]]
#
# HACK: We do not want to force every third-party test suite
# to come up with a half-baked solution to finding its
# own files.
#
if {![info exists ::no(epilogue.eagle)] && [info exists ::path]} then {
unset ::path
}
}
proc hookPuts {} {
#
# NOTE: This code was stolen from "tcltest" and heavily modified to
# work with Eagle.
#
proc [namespace current]::testPuts { args } {
switch [llength $args] {
1 {
#
# NOTE: Only the string to be printed is specified (stdout).
#
return [tputs $::test_channel [appendArgs [lindex $args 0] \n]]
}
2 {
#
# NOTE: Either -nonewline or channelId has been specified.
#
if {[lindex $args 0] eq "-nonewline"} then {
return [tputs $::test_channel [lindex $args end]]
} else {
set channel [lindex $args 0]
set newLine \n
}
}
3 {
#
# NOTE: Both -nonewline and channelId are specified, unless
# it's an error. The -nonewline option is supposed to
# be argv[0].
#
if {[lindex $args 0] eq "-nonewline"} then {
set channel [lindex $args 1]
set newLine ""
}
}
}
if {[info exists channel] && $channel eq "stdout"} then {
#
# NOTE: Write output for stdout to the test channel.
#
return [tputs $::test_channel [appendArgs [lindex $args end] \
$newLine]]
}
#
# NOTE: If we haven't returned by now, we don't know how to
# handle the input. Let puts handle it.
#
return [eval ::tcl::save::puts $args]
}
rename ::puts ::tcl::save::puts; # save Tcl command
rename [namespace current]::testPuts ::puts; # insert our proc
}
proc unhookPuts {} {
rename ::puts ""; # remove our proc
rename ::tcl::save::puts ::puts; # restore Tcl command
}
proc runTest { script } {
#
# NOTE: This should work properly in both Tcl and Eagle as long as the
# "init" script has been evaluated first.
#
if {![isEagle]} then {
hookPuts
}
set code [catch {uplevel 1 $script} result]
set error [expr {$code == 0 ? false : true}]
if {[isEagle]} then {
#
# NOTE: Initially, the call to [tresult] (i.e. [host result]) will
# use the actual return code from the test command; however,
# if that return code was 3 (i.e. break), that indicates the
# test results should be highlighted in yellow -AND- that the
# test should still be considered successful even though the
# test was skipped. If the return code was 4 (i.e. continue),
# that indicates the test results should be highlighted in
# dark yellow -AND- that the test should still be considered
# successful because failures are being ignored for it.
#
set tresultCode $code
if {$code == 3 || $code == 5} then {
set code 0; set error false
} elseif {$code == 4} then {
set code 0
}
#
# NOTE: If the return code from the test command indicates success
# and the test results contain a clear indication of failure,
# reset both return codes to indicate that failure.
#
if {$code == 0 && [regexp -- {\s==== (.*?) FAILED\s} $result]} then {
set code 1; set tresultCode $code
}
#
# NOTE: Display and/or log the results for the test that we just
# completed.
#
if {[shouldWriteTestData $code]} then {
tresult $tresultCode $result
} else {
tlog $result
}
#
# NOTE: If the test failed with an actual error (i.e. not just a
# test failure), make sure we do not obscure the error
# message with test suite output.
#
if {$error} then {
tputs $::test_channel \n; # emit a blank line.
}
#
# NOTE: If this test failed and the stop-on-failure flag is set,
# raise an error now. If we are being run from inside
# runAllTests, this will also serve to signal it to stop
# processing further test files.
#
if {$code != 0 && [isStopOnFailure]} then {
tresult Error "OVERALL RESULT: STOP-ON-FAILURE\n"
unset -nocomplain ::test_suite_running
error ""; # no message
}
#
# NOTE: Unless forbidden from doing so, attempt to automatically
# cleanup any stale (e.g. temporary) object references now.
#
if {![info exists ::no(cleanupReferences)]} then {
catch {object cleanup -references}
}
} else {
if {$error} then {
#
# HACK: Prevent spurious errors dealing with [test] command options
# that are missing from native Tcl.
#
set badOptionPattern {^bad option ".*?":\
must be -body, -cleanup, -constraints, -errorOutput,\
-match, -output, -result, -returnCodes, or -setup$}
set badMatchValuePattern {^bad -match value ".*?": must be\
exact, glob, or regexp$}
if {[isEagle] || \
(![regexp -- $badOptionPattern $result] && \
![regexp -- $badMatchValuePattern $result])} then {
tputs $::test_channel [appendArgs \
"ERROR (runTest): " $result \n]
}
}
unhookPuts
}
#
# HACK: Return an empty string here just in case we are being called
# via the [testShim] procedure. Doing this should prevent any
# superfluous output from being displayed via [host result] in
# the outermost call to this procedure.
#
return ""
}
proc testShim { args } {
#
# NOTE: Call the original (saved) [test] command, wrapping it in
# our standard [runTest] wrapper.
#
uplevel 1 [list runTest [concat ::savedTest $args]]; return ""
}
proc tsource { fileName {prologue true} {epilogue true} } {
#
# NOTE: Run the test prologue in the context of the caller (which
# must be global)?
#
if {$prologue} then {
uplevel 1 runTestPrologue
}
#
# NOTE: Save the original [test] command and setup our test shim in
# its place.
#
rename ::test ::savedTest
interp alias {} ::test {} testShim
#
# NOTE: Source the specified test file in the context of the caller
# (which should be global).
#
set code [catch {uplevel 1 [list source $fileName]} result]
set error [expr {$code == 0 ? false : true}]
#
# NOTE: Remove our test shim and restore the original (saved) [test]
# command.
#
interp alias {} ::test {}
rename ::savedTest ::test
#
# NOTE: Run the test epilogue in the context of the caller (which
# must be global)?
#
if {$epilogue} then {
uplevel 1 runTestEpilogue
}
#
# NOTE: If the test raised an error, re-raise it now; otherwise,
# just return the result.
#
if {$error} then {
unset -nocomplain ::test_suite_running
error $result
} else {
return $result
}
}
proc recordTestStatistics { varName index } {
#
# NOTE: Record counts of all object types that we track.
#
upvar 1 $varName array
###########################################################################
if {![info exists array(uncounted,$index)]} then {
set array(uncounted,$index) [getTestUncountedLeaks]
}
###########################################################################
set array(time,$index) [clock seconds]
set array(afters,$index) [llength [after info]]
set array(variables,$index) [llength [info globals]]
set array(commands,$index) [llength [info commands]]
set array(procedures,$index) [llength [info procs]]
set array(namespaces,$index) [llength [namespace children ::]]
###########################################################################
if {[info exists ::test_path]} then {
set array(files,$index) [llength [getFiles $::test_path *]]
} else {
set array(files,$index) 0; # NOTE: Information not available.
}
###########################################################################
set array(temporaryFiles,$index) [llength [getFiles [getTemporaryPath] *]]
set array(channels,$index) [llength [file channels]]
set array(aliases,$index) [llength [interp aliases]]
set array(interpreters,$index) [llength [interp slaves]]
set array(environment,$index) [llength [array names env]]
set array(loaded,$index) [llength [info loaded]]
###########################################################################
#
# NOTE: These native resource types cannot be positively checked
# for leaks (i.e. because the "leak" may be from an external
# process).
#
if {![info exists ::no(uncountedTemporaryFiles)]} then {
lappend array(uncounted,$index) temporaryFiles
}
###########################################################################
if {[isEagle]} then {
#
# NOTE: Support for some of all of these entity types may not be
# present in the interpreter, initialize all these counts
# to zero and then try to query each one individually below
# wrapped in a catch.
#
set array(previousPid,$index) 0
set array(scopes,$index) 0
set array(assemblies,$index) 0
set array(processes,$index) 0
set array(objects,$index) 0
set array(objectCallbacks,$index) 0
set array(objectTypes,$index) 0
set array(objectInterfaces,$index) 0
set array(objectNamespaces,$index) 0
catch {set array(previousPid,$index) [expr {[info previouspid] != 0}]}
catch {set array(scopes,$index) [llength [scope list]]}
catch {set array(assemblies,$index) [llength [object assemblies]]}
catch {set array(processes,$index) [llength [getProcesses ""]]}
catch {set array(objects,$index) [llength [info objects]]}
catch {set array(objectCallbacks,$index) [llength [info callbacks]]}
catch {set array(objectTypes,$index) [llength [object types]]}
catch {set array(objectInterfaces,$index) [llength [object interfaces]]}
catch {set array(objectNamespaces,$index) [llength [object namespaces]]}
#########################################################################
#
# NOTE: Support for some of all of these entity types may not be
# present in the interpreter, initialize all these counts
# to zero and then try to query each one individually below
# wrapped in a catch.
#
set array(connections,$index) 0
set array(transactions,$index) 0
set array(modules,$index) 0
set array(delegates,$index) 0
set array(tcl,$index) 0
set array(tclInterps,$index) 0
set array(tclThreads,$index) 0
set array(tclCommands,$index) 0
set array(scriptThreads,$index) 0
catch {set array(connections,$index) [llength [info connections]]}
catch {set array(transactions,$index) [llength [info transactions]]}
catch {set array(modules,$index) [llength [info modules]]}
catch {set array(delegates,$index) [llength [info delegates]]}
if {[llength [info commands tcl]] > 0} then {
catch {set array(tcl,$index) [tcl ready]}
catch {set array(tclInterps,$index) [llength [tcl interps]]}
catch {set array(tclThreads,$index) [llength [tcl threads]]}
catch {set array(tclCommands,$index) [llength [tcl command list]]}
}
#
# NOTE: Grab the number of active threads that are active because
# of ScriptThread object instances. This only works if Eagle
# is Beta 31 or higher.
#
catch {
set array(scriptThreads,$index) \
[object invoke -flags +NonPublic ScriptThread activeCount]
}
#########################################################################
#
# NOTE: These managed resource types cannot be positively checked
# for leaks (i.e. because the "leak" may be from an external
# process).
#
if {![info exists ::no(uncountedAssemblies)]} then {
lappend array(uncounted,$index) assemblies
}
if {![info exists ::no(uncountedProcesses)]} then {
lappend array(uncounted,$index) processes
}
}
}
proc reportTestStatistics {
channel fileName stop statsVarName filesVarName {quiet false} } {
set statistics [list afters variables commands procedures namespaces \
files temporaryFiles channels aliases interpreters environment \
loaded]
if {[isEagle]} then {
#
# TODO: For now, tracking "leaked" assemblies is meaningless because
# the .NET Framework has no way to unload them without tearing
# down the entire application domain.
#
lappend statistics \
previousPid scopes assemblies processes objects objectCallbacks \
objectTypes objectInterfaces objectNamespaces connections \
transactions modules delegates tcl tclInterps tclThreads \
tclCommands scriptThreads
}
#
# NOTE: Show what leaked, if anything.
#
set count 0; upvar 1 $statsVarName array
foreach statistic $statistics {
if {![info exists array($statistic,after)]} then {
if {!$quiet} then {
tputs $channel [appendArgs "==== \"" $fileName "\" MISSING " \
$statistic " AFTER\n"]
}
continue
}
if {![info exists array($statistic,before)]} then {
if {!$quiet} then {
tputs $channel [appendArgs "==== \"" $fileName "\" MISSING " \
$statistic " BEFORE\n"]
}
continue
}
if {$array($statistic,after) > $array($statistic,before)} then {
lappend array(statistics,leaked) $statistic
if {!$quiet} then {
tputs $channel [appendArgs "==== \"" $fileName "\" LEAKED " \
$statistic \n]
}
if {[info exists array($statistic,before,list)]} then {
if {!$quiet} then {
tputs $channel [appendArgs "---- " $statistic " BEFORE: " \
[formatList $array($statistic,before,list)] \n]
}
}
if {[info exists array($statistic,after,list)]} then {
if {!$quiet} then {
tputs $channel [appendArgs "---- " $statistic " AFTER: " \
[formatList $array($statistic,after,list)] \n]
}
}
if {[info exists array(uncounted,before)] && \
[lsearch -exact $array(uncounted,before) $statistic] != -1} then {
continue
}
if {[info exists array(uncounted,after)] && \
[lsearch -exact $array(uncounted,after) $statistic] != -1} then {
continue
}
incr count
}
}
#
# NOTE: Make sure this file name is recorded in the list of file names with
# leaking tests.
#
upvar 1 $filesVarName fileNames
if {$count > 0 && \
[lsearch -exact $fileNames [file tail $fileName]] == -1} then {
lappend fileNames [file tail $fileName]
}
#
# NOTE: Disable test suite interaction in "quiet" mode. Just return the
# leak count.
#
if {!$quiet} then {
#
# NOTE: If we are supposed to stop or break into the debugger whenever
# a leak is detected, do it now.
#
if {$count > 0} then {
#
# BUGFIX: Is we are already stopping (e.g. due to a test failure),
# do not try to stop again.
#
if {!$stop && [isStopOnLeak]} then {
tresult Error "OVERALL RESULT: STOP-ON-LEAK\n"
unset -nocomplain ::test_suite_running
error ""; # no message
} elseif {[isBreakOnLeak]} then {
testDebugBreak
}
}
}
return [list leak $count]
}
proc formatList { list {default ""} {columns 1} } {
if {[catch {
set result ""
set count 1
foreach item $list {
if {[incr count -1] == 0} then {
set count $columns
append result \n
}
append result \t
if {[string length $item] > 0} then {
append result $item
} else {
append result <noItem>
}
}
}] == 0} then {
return [expr {[string length $result] > 0 ? $result : $default}]
} else {
return ""
}
}
proc formatListAsDict { list {default ""} } {
if {[catch {
set result ""
foreach {name value} $list {
append result \n\t
if {[string length $name] > 0} then {
append result $name
} else {
append result <noName>
}
append result ": "
if {[string length $value] > 0} then {
append result $value
} else {
append result <noValue>
}
}
}] == 0} then {
return [expr {[string length $result] > 0 ? $result : $default}]
} else {
return ""
}
}
proc pathToRegexp { path {list false} } {
#
# NOTE: This procedure needs to escape all characters that
# have any special meaning to the regular expression
# engine. Typically, the only characters we need to
# really worry about are the directory separator and
# the file extension separator (e.g. backslash and
# period on Windows and/or forward slash and period
# on Unix). Since the forward slash has no special
# meaning to the regular expression engine, Windows
# is somewhat more difficult to handle.
#
set map [list \
\\ \\\\ \$ \\\$ ( \\( ) \\) * \\* + \\+ - \\- . \\. \
? \\? \[ \\\[ \] \\\] ^ \\^ \{ \\\{ \} \\\}]
return [string map $map [expr {$list ? [list $path] : $path}]]
}
proc assemblyNameToRegexp { assemblyName {list false} } {
#
# NOTE: This procedure needs to escape all characters that
# have any special meaning to the regular expression
# engine -AND- that can actually appear in a legal
# assembly name. Normally, this would only include
# the period character.
#
# HACK: For now, just abuse the [pathToRegexp] procedure
# for this.
#
return [pathToRegexp $assemblyName $list]
}
proc inverseLsearchGlob { noCase patterns element } {
#
# NOTE: Perform the inverse of [lsearch -glob], attempt
# to match an element against a list of patterns.
#
set command [list string match]
if {$noCase} then {lappend command -nocase}
set length [llength $patterns]
for {set index 0} {$index < $length} {incr index} {
set pattern [lindex $patterns $index]
if {[eval $command [list $pattern] [list $element]]} then {
return $index
}
}
return -1
}
proc removePathFromFileNames { path fileNames } {
set result [list]
foreach fileName $fileNames {
if {[file normalize [file dirname $fileName]] eq \
[file normalize $path]} then {
#
# NOTE: Strip the path name from this file name.
#
lappend result [file tail $fileName]
} else {
lappend result $fileName
}
}
return $result
}
proc formatDecimal { value {places 4} {zeros false} } {
#
# NOTE: If the value is an empty string, do nothing and return an empty
# string.
#
if {[string length $value] == 0} then {
return ""
}
#
# NOTE: For now, use slightly different methods for formatting floating
# pointer numbers for native Tcl and Eagle.
#
if {[isEagle] && [llength [info commands object]] > 0} then {
#
# HACK: This works; however, in order to do this kind of thing cleanly,
# we really need the Tcl [format] command.
#
set result [object invoke String Format [appendArgs "{0:0." \
[string repeat [expr {$zeros ? "0" : "#"}] $places] "}"] \
[set object [object invoke -create Double Parse $value]]]
unset object; # dispose
} else {
#
# NOTE: See, nice and clean when done in Tcl?
#
set result [format [appendArgs %. $places f] $value]
#
# HACK: Since native Tcl does not appear to expose a method to only
# preserve non-zero trailing digits, we may need to manually
# remove extra trailing zeros.
#
if {!$zeros} then {
#
# NOTE: Remove all trailing zeros and the trailing decimal point,
# if necessary.
#
set result [string trimright [string trimright $result 0] .]
}
}
return $result
}
proc clearTestPercent { channel } {
if {[isEagle]} then {
host title ""
}
}
proc reportTestPercent {
channel percent doneFiles totalFiles failedFiles leakedFiles } {
if {[isEagle]} then {
set totalTests $::eagle_tests(Total)
set failedTests $::eagle_tests(Failed)
set skippedTests $::eagle_tests(Skipped)
} else {
set totalTests $::tcltest::numTests(Total)
set failedTests $::tcltest::numTests(Failed)
set skippedTests $::tcltest::numTests(Skipped)
}
set status [appendArgs \
"---- test suite running, about " $percent "% complete (" \
$totalTests " tests total, " $failedTests " tests failed, " \
$skippedTests " tests skipped, " $doneFiles " files done, " \
$totalFiles " files total, " $failedFiles " files failed, " \
$leakedFiles " files leaked)..."]
tputs $channel [appendArgs $status \n]
if {[isEagle]} then {
host title $status
}
}
proc reportArrayGet { varName } {
if {[string length $varName] == 0} then {
return [list]
}
upvar 1 $varName array
if {![info exists ::no(reportArrayGet)]} then {
set list(1) [list]
foreach {name value} [array get array] {
lappend list(1) [list $name $value]
}
#
# HACK: This assumes that we are dealing with integer values.
#
set list(2) [lsort -index 1 -integer -decreasing $list(1)]
set list(3) [list]
foreach pair $list(2) {
lappend list(3) [lindex $pair 0] [lindex $pair 1]
}
return $list(3)
} else {
return [array get array]
}
}
proc reportTestStatisticCounts { channel statsVarName } {
upvar 1 $statsVarName array
#
# NOTE: Were any counts recorded during the testing?
#
if {[info exists array(statistics,leaked)]} then {
#
# NOTE: Process each leak type in the list, recording any duplicates
# in the temporary count array.
#
foreach statistic $array(statistics,leaked) {
if {[info exists count($statistic)]} then {
incr count($statistic)
} else {
set count($statistic) 1
}
}
#
# NOTE: Flatten the temporary count array into a dictionary formatted
# list and then possibly display it (i.e. if it actually contains
# any data).
#
set statistics [reportArrayGet count]
if {[llength statistics] > 0} then {
tputs $channel [appendArgs "---- types of leaks detected: " \
[formatListAsDict $statistics] \n]
}
}
}
proc runAllTests {
channel path fileNames skipFileNames startFileNames stopFileNames } {
#
# NOTE: Are we configured to run the test files in random order?
#
if {[isRandomOrder]} then {
set fileNames [lshuffle $fileNames]
}
#
# NOTE: Show the exact arguments we received since they may not
# have been displayed by the caller (or anybody else).
#
if {![info exists ::no(runMetadata)]} then {
tputs $channel [appendArgs "---- test run path: \"" $path \"\n]
tputs $channel [appendArgs "---- test run file names: " \
[formatList [removePathFromFileNames $path $fileNames]] \n]
tputs $channel [appendArgs "---- test run skip file names: " \
[formatList $skipFileNames] \n]
}
#
# NOTE: Keep going unless this becomes true (i.e. if one of the
# test files signals us to stop).
#
set stop false
#
# NOTE: So far, we have run no tests.
#
set count 0
#
# NOTE: So far, no files have had failing or leaking tests.
#
set failed [list]
set leaked [list]
#
# NOTE: Process each file name we have been given by the caller...
#
set total [llength $fileNames]; set lastPercent -1
foreach fileName $fileNames {
#
# NOTE: If configured to break into the debugger before running the
# test file, do it now.
#
if {[isBreakOnDemand]} then {
testDebugBreak
}
#
# NOTE: In terms of files, not tests, what percent done are we now?
#
set percent [formatDecimal \
[expr {$total != 0 ? 100.0 * ($count / double($total)) : 0}]]
if {$percent != $lastPercent} then {
if {![info exists ::no(runPercent)]} then {
reportTestPercent $channel $percent \
$count $total [llength $failed] [llength $leaked]
}
set lastPercent $percent
}
#
# NOTE: If the starting file names have been specified by the caller,
# skip over all the file names before one of them.
#
if {[llength $startFileNames] > 0} then {
if {[inverseLsearchGlob false $startFileNames \
[file tail $fileName]] != -1} then {
#
# NOTE: Now that we found the starting test file name, do not
# skip any more test files.
#
set startFileNames [list]
} else {
#
# NOTE: We have not found the starting test file name yet, skip
# over this test file.
#
continue
}
}
#
# NOTE: If the stopping file names have been specified by the caller,
# skip over all the file names after one of them.
#
if {[llength $stopFileNames] > 0} then {
if {[inverseLsearchGlob false $stopFileNames \
[file tail $fileName]] != -1} then {
#
# NOTE: Now that we found the stopping test file name, do not
# run any more test files.
#
set stopFileNames [list]
#
# NOTE: This will terminate the loop right after the test file
# cleanup code (i.e. at the bottom of the loop).
#
set stop true
}
}
#
# NOTE: Skipping over any file name that matches a pattern in the
# list of file names to skip.
#
if {[inverseLsearchGlob false $skipFileNames \
[file tail $fileName]] == -1} then {
#
# NOTE: Does the file name contain directory information?
#
if {[string length [file dirname $fileName]] <= 1} then {
#
# NOTE: If not, assume it is under the supplied test path.
#
set fileName [file normalize [file join $path $fileName]]
}
#
# NOTE: The "magic" pattern we are looking for to determine if
# a given file is part of the formal test suite.
#
set pattern {^(\s)*runTest .*$}
#
# NOTE: Skip files that are not part of the test suite.
#
set data [readFile $fileName]
#
# NOTE: Check for a match.
#
set match [regexp -line -- $pattern $data]
#
# NOTE: Failing that, in Eagle only, check if the data, when
# interpreted as Unicode, matches the pattern.
#
if {!$match && [isEagle]} then {
set match [regexp -line -- $pattern \
[encoding convertfrom unicode $data]]
}
#
# NOTE: Does this "look" like an actual test suite file?
#
if {$match} then {
#
# BUGFIX: Unset the current test file name so that variable
# accounting works correctly. It will be reset below
# prior to running any actual test(s).
#
unset -nocomplain ::test_file
#
# NOTE: Is resource leak checking explicitly disabled?
#
if {![info exists ::no(leak)]} then {
#
# NOTE: Get "before" resource counts for leak tracking.
#
recordTestStatistics leaks before
}
#
# NOTE: Let the test prologue code know which file we are
# evaluating.
#
set ::test_file $fileName
#
# NOTE: Record failed test count before this file.
#
if {[isEagle]} then {
set before $::eagle_tests(Failed)
} else {
set before $::tcltest::numTests(Failed)
}
#
# NOTE: Evaluate the test file, optionally waiting for a certain
# number of milliseconds before and/or after doing so.
#
if {[catch {
#
# NOTE: Are we being prevented from waiting before the file?
#
if {![info exists ::no(preWait)]} then {
if {[info exists ::test_wait(pre)] && \
[string is integer -strict $::test_wait(pre)]} then {
if {![info exists ::no(runMetadata)]} then {
tputs $channel [appendArgs \
"---- waiting for " $::test_wait(pre) \
" milliseconds before test file...\n"]
}
after $::test_wait(pre); # NOTE: Sleep.
}
}
#
# NOTE: Log that this test file has started.
#
if {![info exists ::no(runStartFile)]} then {
tputs $channel [appendArgs "==== \"" $fileName "\" START\n"]
}
#
# NOTE: Evaluate the file in the context of the caller,
# catching any errors. If an error is raised and
# the stop-on-failure flag is set, assume it was
# a test failure and that we need to stop any and
# all further processing of test files.
#
uplevel 1 [list source $fileName]
#
# NOTE: Log that this test file has ended.
#
if {![info exists ::no(runEndFile)]} then {
tputs $channel [appendArgs "==== \"" $fileName "\" END\n"]
}
#
# NOTE: Are we being prevented from waiting after the file?
#
if {![info exists ::no(postWait)]} then {
if {[info exists ::test_wait(post)] && \
[string is integer -strict $::test_wait(post)]} then {
if {![info exists ::no(runMetadata)]} then {
tputs $channel [appendArgs \
"---- waiting for " $::test_wait(post) \
" milliseconds after test file...\n"]
}
after $::test_wait(post); # NOTE: Sleep.
}
}
} error]} then {
#
# NOTE: Most likely, this error was caused by malformed or
# incorrect code in-between the tests themselves. We
# need to report this.
#
if {![info exists ::no(runErrorFile)]} then {
tputs $channel [appendArgs "==== \"" $fileName "\" ERROR \"" \
$error \"\n]
}
#
# NOTE: Stop further processing after this loop iteration?
#
if {[isStopOnFailure]} then {
#
# NOTE: This will terminate the loop right after the test
# file cleanup code (i.e. at the bottom of the loop).
#
set stop true
#
# BUGFIX: If there are no actual test failures recorded yet,
# make sure there is one now. This is necessary to
# handle the case where an error occurs in a test
# file that does not directly cause at least one of
# its contained tests to fail. Otherwise, the test
# suite will still be stopped; however, an overall
# result of success will be returned by the process.
#
if {[isEagle]} then {
if {$::eagle_tests(Failed) == 0} then {
incr ::eagle_tests(Total)
incr ::eagle_tests(Failed)
}
} else {
if {$::tcltest::numTests(Failed) == 0} then {
incr ::tcltest::numTests(Total)
incr ::tcltest::numTests(Failed)
}
}
} else {
#
# NOTE: At this point, we know the test file had an error that
# probably caused it to skip a bunch of tests -AND- the
# option to stop-testing-on-error is not enabled. That
# being said, we must not simply ignore the error. The
# overall results of the test suite run must now reflect
# the failure. Set a special variable for the epilogue
# to pick up on (later).
#
lappend ::test_suite_errors [list $fileName $error]
}
}
#
# NOTE: Record failed test count after this file.
#
if {[isEagle]} then {
set after $::eagle_tests(Failed)
} else {
set after $::tcltest::numTests(Failed)
}
#
# NOTE: Did this file have any failing tests?
#
if {$after > $before} then {
lappend failed [file tail $fileName]
}
#
# NOTE: In terms of files, not tests, what percent done are we now?
#
set percent [formatDecimal \
[expr {$total != 0 ? 100.0 * ($count / double($total)) : 0}]]
if {$percent != $lastPercent} then {
if {![info exists ::no(runPercent)]} then {
reportTestPercent $channel $percent \
$count $total [llength $failed] [llength $leaked]
}
set lastPercent $percent
}
#
# NOTE: Unset the current test file name, it is no longer
# needed.
#
unset -nocomplain ::test_file
#
# NOTE: Is resource leak checking explicitly disabled?
#
if {![info exists ::no(leak)]} then {
#
# NOTE: Get "after" resource counts for leak tracking.
#
recordTestStatistics leaks after
if {![info exists ::no(runStatistics)]} then {
#
# NOTE: Determine if any resource leaks have occurred and
# output diagnostics as necessary if they have.
#
reportTestStatistics $channel $fileName $stop leaks leaked
}
}
} else {
#
# NOTE: This entire file has been skipped. Record that fact in the
# test suite log file.
#
if {![info exists ::no(runNonTestFile)]} then {
tputs $channel [appendArgs \
"==== \"" $fileName "\" NON_TEST_FILE\n"]
}
}
#
# NOTE: Another file of some kind was processed. It may have been
# skipped; however, that does not matter.
#
incr count
#
# NOTE: In terms of files, not tests, what percent done are we now?
#
set percent [formatDecimal \
[expr {$total != 0 ? 100.0 * ($count / double($total)) : 0}]]
if {$percent != $lastPercent} then {
if {![info exists ::no(runPercent)]} then {
reportTestPercent $channel $percent \
$count $total [llength $failed] [llength $leaked]
}
set lastPercent $percent
}
#
# NOTE: If the test file raised an error (i.e. to indicate a
# test failure with the stop-on-failure flag enabled),
# break out of the test loop now.
#
if {$stop} then {
break
}
} else {
#
# NOTE: This entire file has been skipped. Record that fact in the
# test suite log file.
#
if {![info exists ::no(runSkippedFile)]} then {
tputs $channel [appendArgs "==== \"" $fileName "\" SKIPPED\n"]
}
#
# NOTE: This file was skipped.
#
incr count
}
#
# NOTE: In terms of files, not tests, what percent done are we now?
#
set percent [formatDecimal \
[expr {$total != 0 ? 100.0 * ($count / double($total)) : 0}]]
if {$percent != $lastPercent} then {
if {![info exists ::no(runPercent)]} then {
reportTestPercent $channel $percent \
$count $total [llength $failed] [llength $leaked]
}
set lastPercent $percent
}
}
#
# NOTE: Reset the host title because we may have changed it in the for
# loop (above).
#
if {![info exists ::no(runPercent)]} then {
clearTestPercent $channel
}
if {![info exists ::no(runMetadata)]} then {
tputs $channel [appendArgs "---- sourced " $count " test " \
[expr {$count > 1 ? "files" : "file"}] \n]
#
# NOTE: Show the files that had failing and/or leaking tests.
#
if {[llength $failed] > 0} then {
tputs $channel [appendArgs "---- files with failing tests: " \
[formatList $failed] \n]
}
if {[llength $leaked] > 0} then {
tputs $channel [appendArgs "---- files with leaking tests: " \
[formatList $leaked] \n]
}
}
if {![info exists ::no(runStatisticCounts)]} then {
reportTestStatisticCounts $channel leaks
}
}
proc isTestSuiteRunning {} {
#
# NOTE: Return non-zero if the test suite appears to be running.
#
return [expr {[info exists ::test_suite_running] && \
$::test_suite_running}]
}
proc getTestChannelOrDefault {} {
if {[info exists ::test_channel]} then {
return $::test_channel
}
return stdout; # TODO: Good default?
}
proc tryVerifyTestPath {} {
#
# NOTE: If the test path variable does not exist, the directory it
# points to does not exist (or is not really a directory), or
# it appears to be an empty directory, return false; otherwise,
# return true.
#
if {![info exists ::test_path] || \
![file exists $::test_path] || \
![file isdirectory $::test_path] || \
[llength [getFiles $::test_path *]] == 0} then {
return false
}
return true
}
proc checkForAndSetTestPath { whatIf {quiet false} } {
#
# NOTE: Everything in this procedure requires access to the file system;
# therefore, it cannot be used in a stock "safe" interpreter.
#
if {![interp issafe] && ![info exists ::test_path]} then {
#
# NOTE: Grab the name of the current script file. If this is an empty
# string, many test path checks will have to be skipped.
#
set script [info script]
#
# NOTE: Eagle and native Tcl have different requirements and possible
# locations for the test path; therefore, handle them separately.
#
if {[isEagle]} then {
#
# NOTE: Grab the base directory and the library directory. Without
# these, several test path checks will be skipped.
#
set library [getTestLibraryDirectory]; set base [info base]
if {[string length $library] > 0} then {
#
# NOTE: Try the source release directory structure. For this
# case, the final test path would be:
#
# $library/../../Library/Tests
#
set ::test_path [file normalize [file join [file dirname [file \
dirname $library]] Library Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #1 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $base] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Try the source release directory structure again; this
# time, assume only the embedded script library was used.
# For this case, the final test path would be:
#
# $base/Library/Tests
#
set ::test_path [file normalize [file join $base Library Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #2 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $script] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Try for the test package directory. For this case, the
# final test path would be:
#
# $script/../Test1.0
#
set ::test_path [file normalize [file join [file dirname [file \
dirname $script]] [appendArgs Test [info engine Version]]]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #3 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $base] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Try for the test package directory again; this time, use
# the base path and assume the source release directory
# structure. For this case, the final test path would be:
#
# $base/lib/Test1.0
#
set ::test_path [file normalize [file join $base lib [appendArgs \
Test [info engine Version]]]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #4 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $base] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Try for the test package directory again; this time, use
# the base path. For this case, the final test path would
# be:
#
# $base/Test1.0
#
set ::test_path [file normalize [file join $base [appendArgs \
Test [info engine Version]]]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #5 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $library] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: This must be a binary release, no "Library" directory
# then. Also, binary releases have an upper-case "Tests"
# directory name that originates from the "update.bat"
# tool. This must match the casing used in "update.bat".
# For this case, the final test path would be:
#
# $library/../../Tests
#
set ::test_path [file normalize [file join [file dirname [file \
dirname $library]] Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #6 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $base] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Fallback to using the base directory and checking for a
# "Tests" directory beneath it. For this case, the final
# test path would be:
#
# $base/Tests
#
set ::test_path [file normalize [file join $base Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #7 for Eagle test path at \"" \
$::test_path \"...\n]
}
}
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- final Eagle test path is \"" \
[expr {[info exists ::test_path] ? \
$::test_path : "<none>"}] \"\n]
}
} else {
if {[string length $script] > 0} then {
#
# NOTE: Try the source release directory structure. For this
# case, the final test path would be:
#
# $script/../../Library/Tests
#
set ::test_path [file normalize [file join [file dirname [file \
dirname [file dirname $script]]] Library Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #1 for Tcl test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $script] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: Try for the test package directory. For this case, the
# final test path would be:
#
# $script/../Test1.0
#
set ::test_path [file normalize [file join [file dirname [file \
dirname $script]] Test1.0]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #2 for Tcl test path at \"" \
$::test_path \"...\n]
}
}
if {[string length $script] > 0 && \
($whatIf || ![tryVerifyTestPath])} then {
#
# NOTE: This must be a binary release, no "Library" directory
# then. Also, binary releases have an upper-case "Tests"
# directory name that originates from the "update.bat"
# tool. This must match the casing used in "update.bat".
# For this case, the final test path would be:
#
# $script/../../Tests
#
set ::test_path [file normalize [file join [file dirname [file \
dirname [file dirname $script]]] Tests]]
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- checking #3 for Tcl test path at \"" \
$::test_path \"...\n]
}
}
if {!$quiet} then {
tqputs [getTestChannelOrDefault] [appendArgs \
"---- final Tcl test path is \"" \
[expr {[info exists ::test_path] ? \
$::test_path : "<none>"}] \"\n]
}
}
}
}
proc configureTcltest { verbose match skip constraints imports force } {
#
# NOTE: Eagle and native Tcl have different configuration requirements
# for the "tcltest" package. For Eagle, the necessary testing
# functionality is built-in. In native Tcl, the package must be
# loaded now and that cannot be done in a "safe" interpreter.
#
if {[isEagle]} then {
#
# HACK: Flag the "test" and "runTest" script library procedures so
# that they use the script location of their caller and not
# their own.
#
# BUGBUG: Even this does not yet fix the script location issues in
# the test suite:
#
# debug procedureflags test +ScriptLocation
# debug procedureflags runTest +ScriptLocation
#
# NOTE: Setup the necessary compatibility shims for the test suite.
#
namespace eval ::tcltest {}; # HACK: Force namespace creation now.
setupTestShims true [expr {![isTestSuiteRunning]}]
#
# NOTE: Fake having the package as the functionality is built-in.
#
package provide tcltest 2.2.10; # Tcl 8.4
} elseif {![interp issafe]} then {
#
# NOTE: Attempt to detect if the package is already loaded.
#
set loaded [expr {[catch {package present tcltest}] == 0}]
#
# NOTE: Always attempt to load the package.
#
package require tcltest
#
# NOTE: Configure it for our use (only when it was not loaded).
#
if {!$loaded} then {
if {[string length $verbose] > 0} then {
::tcltest::configure -verbose $verbose
} else {
::tcltest::configure -verbose pbste
}
}
#
# NOTE: We need to copy the Eagle test names to match over to Tcl.
#
if {[llength $match] > 0} then {
::tcltest::configure -match $match
}
#
# NOTE: We need to copy the Eagle test names to skip over to Tcl.
#
if {[llength $skip] > 0} then {
::tcltest::configure -skip $skip
}
#
# NOTE: We need to copy the Eagle test constraints over to Tcl.
#
if {[llength $constraints] > 0} then {
::tcltest::configure -constraints $constraints
}
#
# NOTE: For the benefit of the Eagle test suite, always add the
# pseudo-constraints "fail.false" and "fail.true".
#
::tcltest::testConstraint fail.false 1
::tcltest::testConstraint fail.true 1
#
# NOTE: We need the [test] command in the global namespace.
#
if {[llength $imports] > 0} then {
set command [list namespace import]
if {$force} then {
lappend command -force
}
foreach import $imports {
lappend command [appendArgs ::tcltest:: $import]
}
namespace eval :: $command
}
}
}
proc machineToPlatform { machine {architecture false} } {
#
# NOTE: Cannot use "-nocase" option here because Tcl 8.4 does not
# support it (i.e. because it is pre-TIP #241).
#
switch -exact -- [string tolower $machine] {
intel {
if {!$architecture && [isWindows]} then {
return Win32
} else {
return x86
}
}
arm {
return arm
}
ia64 {
return itanium
}
msil {
return clr
}
amd64 {
return x64
}
ia32_on_win64 {
return wow64
}
arm64 {
return arm64
}
default {
return unknown
}
}
}
proc architectureForPlatform { platform } {
#
# NOTE: Cannot use "-nocase" option here because Tcl 8.4 does not
# support it (i.e. because it is pre-TIP #241).
#
switch -exact -- [string tolower $platform] {
intel -
win32 -
x86 {
return x86
}
arm {
return arm
}
ia64 -
itanium {
return ia64
}
msil -
clr {
return msil
}
amd64 -
x64 {
return x64
}
ia32_on_win64 -
wow64 {
return ia32_on_win64
}
arm64 {
return arm64
}
default {
return unknown
}
}
}
if {[isEagle]} then {
###########################################################################
############################ BEGIN Eagle ONLY #############################
###########################################################################
proc initializeTests {} {
uplevel #0 {
#
# NOTE: Reset the information in the global "tests" array, which is
# used to interface with the internal test tracking information
# in the interpreter via a variable trace.
#
set eagle_tests(Total) 0
set eagle_tests(Skipped) 0
set eagle_tests(Passed) 0
set eagle_tests(Failed) 0
#
# NOTE: Setup the lists of patterns to match test names against. In
# Eagle, these originate from the command line arguments and are
# passed to the interpreter via this virtual array.
#
if {[info exists test_flags(-match)]} then {
set eagle_tests(MatchNames) $test_flags(-match); # run these tests.
} else {
set eagle_tests(MatchNames) [list *]; # default to running all tests.
}
if {[info exists test_flags(-skip)]} then {
set eagle_tests(SkipNames) $test_flags(-skip); # skip these tests.
} else {
set eagle_tests(SkipNames) [list]; # default to skipping no tests.
}
#
# NOTE: What tests have been skipped, if any?
#
set eagle_tests(SkippedNames) [list]
#
# NOTE: What tests have failed, if any?
#
set eagle_tests(FailedNames) [list]
#
# NOTE: Initialize the list of active test constraints from the
# environment variable and/or the test flags.
#
set eagle_tests(Constraints) [getEnvironmentVariable testConstraints]
if {[info exists test_flags(-constraints)]} then {
eval lappend eagle_tests(Constraints) $test_flags(-constraints)
}
unset -nocomplain test_verbose
set test_verbose [getEnvironmentVariable testVerbose]
if {[string length $test_verbose] == 0} then {
set test_verbose Default
}
if {[info exists test_flags(-verbose)] && \
[string length $test_flags(-verbose)] > 0} then {
#
# NOTE: Map all test verbosity flags we support for script usage
# to their abbreviated names (which are all one letter) and
# then split them into a list.
#
set test_verbose [split [string map [list \
Body B Pass P Skip S Start T Error E Line L \
Fail F Reason R Time I Exit X StdOut O StdErr D] \
$test_flags(-verbose)] ""]
}
set eagle_tests(Verbose) $test_verbose; unset test_verbose
}
}
proc setupTestShims { setup {quiet false} } {
if {$setup} then {
#
# HACK: Compatibility shim(s) for use with various tests in the Tcl
# test suite. Make sure these commands do not already exist
# prior to attempt to adding them.
#
if {[llength [info commands testConstraint]] == 0} then {
interp alias {} testConstraint {} haveOrAddConstraint
if {!$quiet} then {
tqputs [getTestChannelOrDefault] \
"---- added \"testConstraint\" alias\n"
}
}
if {[llength [info commands ::tcltest::testConstraint]] == 0} then {
interp alias {} ::tcltest::testConstraint {} haveOrAddConstraint
if {!$quiet} then {
tqputs [getTestChannelOrDefault] \
"---- added \"::tcltest::testConstraint\" alias\n"
}
}
#
# NOTE: This is needed by most tests in the Tcl test suite. Make
# sure this command does not already exist prior to adding it.
#
if {[llength [info commands ::tcltest::cleanupTests]] == 0} then {
proc ::tcltest::cleanupTests { args } {}
if {!$quiet} then {
tqputs [getTestChannelOrDefault] \
"---- added \"::tcltest::cleanupTests\" procedure\n"
}
}
#
# NOTE: This is needed by some tests in the Tcl test suite. Make
# sure this command does not already exist prior to adding it.
#
if {[llength [info commands \
::tcltest::loadTestedCommands]] == 0} then {
proc ::tcltest::loadTestedCommands { args } {}
if {!$quiet} then {
tqputs [getTestChannelOrDefault] \
"---- added \"::tcltest::loadTestedCommands\" procedure\n"
}
}
} else {
#
# NOTE: Remove the compatibility shim command aliases that we setup
# earlier.
#
if {[llength [info commands \
::tcltest::loadTestedCommands]] > 0} then {
rename ::tcltest::loadTestedCommands ""
if {!$quiet} then {
tqputs $::test_channel \
"---- removed \"::tcltest::loadTestedCommands\" procedure\n"
}
}
if {[llength [info commands ::tcltest::cleanupTests]] > 0} then {
rename ::tcltest::cleanupTests ""
if {!$quiet} then {
tqputs $::test_channel \
"---- removed \"::tcltest::cleanupTests\" procedure\n"
}
}
if {[llength [interp aliases ::tcltest::testConstraint]] > 0} then {
interp alias {} ::tcltest::testConstraint {} {}
if {!$quiet} then {
tqputs $::test_channel \
"---- removed \"::tcltest::testConstraint\" alias\n"
}
}
if {[llength [interp aliases testConstraint]] > 0} then {
interp alias {} testConstraint {} {}
if {!$quiet} then {
tqputs $::test_channel \
"---- removed \"testConstraint\" alias\n"
}
}
}
}
proc shouldWriteTestData { code } {
if {[llength [info commands object]] > 0 && [catch {
object invoke -flags +NonPublic \
Eagle._Components.Private.TestOps ShouldWriteTestData "" $code
} writeTestData] == 0 && $writeTestData} then {
return false
}
return true
}
proc probeForScriptFileName { {excludePatterns ""} {overridePatterns ""} } {
if {[llength [info commands object]] > 0 && [catch {
set locations [object invoke -alias -flags +NonPublic \
Interpreter.GetActive ScriptLocations]
set count [$locations Count]
for {set index 0} {$index < $count} {incr index} {
set location [$locations -alias Peek $index]
if {[isNonNullObjectHandle $location]} then {
set locationFileName [file normalize [$location FileName]]
if {[string length $locationFileName] > 0} then {
if {[llength $overridePatterns] > 0 && \
[lsearch -inverse -glob -- \
$overridePatterns $locationFileName] != -1} then {
return $locationFileName
}
if {[llength $excludePatterns] == 0 || \
[lsearch -inverse -glob -- \
$excludePatterns $locationFileName] == -1} then {
return $locationFileName
}
}
}
}
return ""
} result] in [list 0 2]} then {
return $result
}
return ""
}
proc tresult { code result } {
host result $code $result; tlog $result
}
proc getPassedPercentage {} {
if {$::eagle_tests(Total) > 0} then {
return [expr \
{100.0 * (($::eagle_tests(Passed) + \
$::eagle_tests(Skipped)) / \
double($::eagle_tests(Total)))}]
}
return 0; # no tests were run, etc.
}
proc getSkippedPercentage {} {
if {$::eagle_tests(Total) > 0} then {
return [expr \
{100.0 * ($::eagle_tests(Skipped) / \
double($::eagle_tests(Total)))}]
}
return 0; # no tests were run, etc.
}
proc getDisabledPercentage {} {
if {$::eagle_tests(Total) > 0} then {
return [expr \
{100.0 * ($::eagle_tests(Disabled) / \
double($::eagle_tests(Total)))}]
}
return 0; # no tests were run, etc.
}
proc testObjectMembers { args } {
if {[llength $args] == 0} then {
error [appendArgs \
"wrong # args: should be \"" \
[lindex [info level [info level]] 0] \
" ?options? object\""]
}
set command [list object members]
eval lappend command $args
return [lsort [uplevel 1 $command]]
}
proc createThread { script {parameterized false} {maxStackSize ""} } {
if {[isDotNetCore]} then {
#
# HACK: This seems to make .NET Core happier for reasons
# that are not entirely clear.
#
set typeName "System.Threading.Thread, mscorlib"
} else {
set typeName System.Threading.Thread
}
if {$parameterized} then {
if {[string length $maxStackSize] > 0} then {
return [object create -alias -objectflags +NoReturnReference \
-parametertypes [list System.Threading.ParameterizedThreadStart \
System.Int32] $typeName $script $maxStackSize]
} else {
return [object create -alias -objectflags +NoReturnReference \
-parametertypes [list System.Threading.ParameterizedThreadStart] \
$typeName $script]
}
} else {
if {[string length $maxStackSize] > 0} then {
return [object create -alias -objectflags +NoReturnReference \
-parametertypes [list System.Threading.ThreadStart \
System.Int32] $typeName $script $maxStackSize]
} else {
return [object create -alias -objectflags +NoReturnReference \
-parametertypes [list System.Threading.ThreadStart] \
$typeName $script]
}
}
}
proc startThread { thread {parameterized false} {parameter null} } {
if {$parameterized} then {
$thread Start $parameter
} else {
$thread Start
}
}
proc cleanupThread { thread {timeout 2000} } {
#
# HACK: When running on .NET Core, it seems that using the Interrupt
# method can result in a held lock being lost, even when using
# a lock statement, which should have try / finally semantics.
# Therefore, in that case, attempt to wait on the thread prior
# to attempting to use the Interrupt method.
#
if {[isDotNetCore]} then {
if {[$thread IsAlive]} then {
if {[catch {$thread Join $timeout} error]} then {
tputs $::test_channel [appendArgs \
"---- failed to pre-join test thread \"" $thread "\": " \
$error \n]
} elseif {$error} then {
tputs $::test_channel [appendArgs \
"---- pre-joined test thread \"" $thread \"\n]
} else {
tputs $::test_channel [appendArgs \
"---- timeout pre-joining test thread \"" $thread " (" \
$timeout " milliseconds)\"\n"]
}
}
}
if {[$thread IsAlive]} then {
if {[catch {$thread Interrupt} error]} then {
tputs $::test_channel [appendArgs \
"---- failed to interrupt test thread \"" $thread "\": " \
$error \n]
} else {
tputs $::test_channel [appendArgs "---- test thread \"" $thread \
"\" interrupted\n"]
}
if {[$thread IsAlive]} then {
if {[catch {$thread Join $timeout} error]} then {
tputs $::test_channel [appendArgs \
"---- failed to join test thread \"" $thread "\": " \
$error \n]
} elseif {$error} then {
tputs $::test_channel [appendArgs "---- joined test thread \"" \
$thread \"\n]
} else {
tputs $::test_channel [appendArgs \
"---- timeout joining test thread \"" $thread " (" \
$timeout " milliseconds)\"\n"]
}
if {[$thread IsAlive]} then {
if {[catch {$thread Abort} error]} then {
tputs $::test_channel [appendArgs \
"---- failed to abort test thread \"" $thread "\": " \
$error \n]
} else {
tputs $::test_channel [appendArgs "---- test thread \"" \
$thread "\" aborted\n"]
}
if {[$thread IsAlive]} then {
tputs $::test_channel [appendArgs "---- test thread \"" \
$thread "\" appears to be a zombie\n"]
} else {
return true; # aborted?
}
} else {
return true; # joined?
}
} else {
return true; # interrupted?
}
} else {
return true; # already dead?
}
return false; # still alive (or error).
}
proc reportTestConstraintCounts { channel skippedNames } {
#
# NOTE: Process the list of skipped tests, which is really a dictionary
# of test names to the list of constraints that caused them to be
# skipped. We need to "roll them up", on a per-constraint basis,
# and produce counts for each constraint. At the same time, we
# need to keep track of the maximum count seen, to help align the
# final output.
#
set maximum 0
foreach {testName constraintNames} $skippedNames {
foreach constraintName $constraintNames {
if {[info exists skippedCounts($constraintName)]} then {
incr skippedCounts($constraintName)
} else {
set skippedCounts($constraintName) 1
}
if {$skippedCounts($constraintName) > $maximum} then {
set maximum $skippedCounts($constraintName)
}
}
}
#
# NOTE: Produce the final output, which includes a single line header
# followed by one line per test constraint seen.
#
if {$maximum > 0 && [array size skippedCounts] > 0} then {
set places [expr {int(log10($maximum)) + 1}]
tputs $channel "Number of tests skipped for each constraint:\n"
foreach {name value} [reportArrayGet skippedCounts] {
tputs $channel [appendArgs \
\t [format [appendArgs % $places s] $value] \t $name \n]
}
tputs $channel \n
}
}
proc purgeAndCleanup { channel name } {
catch {uplevel 1 [list debug purge]} result
tputs $channel [appendArgs \
"---- purge \"" $name "\" results: " $result \n]
catch {uplevel 1 [list debug cleanup {
Default -Miscellaneous
}]} result
tputs $channel [appendArgs \
"---- cleanup \"" $name "\" results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.ProcessOps ClearOutputCache]} result
tputs $channel [appendArgs \
"---- ProcessOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.EnumOps ClearEnumCache]} result
tputs $channel [appendArgs \
"---- EnumOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.HelpOps ClearHelpCache]} result
tputs $channel [appendArgs \
"---- HelpOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.StringOps ClearPreambleEncodings]} result
tputs $channel [appendArgs \
"---- StringOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Comparers.FileName ClearCache]} result
tputs $channel [appendArgs \
"---- Comparers.FileName cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.HashOps Cleanup]} result
tputs $channel [appendArgs \
"---- HashOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.FactoryOps Cleanup]} result
tputs $channel [appendArgs \
"---- FactoryOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.ScriptOps ClearInterpreterCache]} result
tputs $channel [appendArgs \
"---- ScriptOps cleanup results: " $result \n]
catch {uplevel 1 [list object invoke -flags +NonPublic \
Eagle._Components.Private.SyntaxOps ClearCache]} result
tputs $channel [appendArgs \
"---- SyntaxOps cleanup results: " $result \n]
}
proc evalWithTimeout { script {milliseconds 2000} {resultVarName ""} } {
#
# NOTE: Verify that the number of milliseconds requested is greater than
# zero.
#
if {$milliseconds <= 0} then {
error "number of milliseconds must be greater than zero"
}
#
# NOTE: Evaluate the specified script in the context of the caller,
# returning the result to the caller.
#
if {[string length $resultVarName] > 0} then {
upvar 1 $resultVarName result
}
return [catch {
#
# NOTE: Evaluate the script in the context of the caller, forcing
# any [vwait] that may be in the contained script to stop
# when it hits a script cancellation -AND- reset the script
# cancellation flags upon completion (i.e. important due to
# the use of script cancellation to enforce the timeout).
#
uplevel 1 [list \
debug secureeval -nocancel true -stoponerror true -timeout \
$milliseconds {} $script]
} result]
}
proc vwaitWithTimeout { varName {milliseconds 2000} } {
#
# NOTE: Verify that the number of milliseconds requested is positive
# or zero.
#
if {$milliseconds < 0} then {
error "number of milliseconds cannot be negative"
}
if {[catch {
#
# NOTE: Refer to the specified variable in the context of our
# caller.
#
upvar 1 $varName variable
#
# NOTE: Wait for the variable to be changed -OR- for the wait
# to be canceled.
#
vwait -eventwaitflags {+NoBgError StopOnError} -force -timeout \
$milliseconds -- variable
} result] == 0} then {
#
# NOTE: The wait completed successfully, the variable may have
# been changed.
#
return $result
} else {
#
# NOTE: The wait failed in some way, it may have been canceled
# and the variable may or may not have been changed.
#
return false
}
}
proc tclLoadForTest { {varName ""} {findFlags ""} {loadFlags ""} } {
if {[string length $varName] > 0} then {
upvar 1 $varName loaded
}
set loaded 0
if {![tcl ready]} then {
set command [list tcl load]
if {[string length $findFlags] > 0} then {
lappend command -findflags $findFlags
}
if {[string length $loadFlags] > 0} then {
lappend command -loadflags $loadFlags
}
uplevel 1 $command; set loaded 1
set module [tcl module]
set interp [tcl master]
tputs $::test_channel [appendArgs \
"---- native Tcl loaded, module \"" $module \
"\", interpreter \"" $interp \"\n]
}
}
proc tclUnloadForTest { {force false} {varName ""} } {
set unload false
if {$force} then {
#
# NOTE: This cannot check [tcl ready] as some tests actually
# rely upon errors from the [tcl unload] sub-command.
#
set unload true
}
if {[string length $varName] > 0} then {
upvar 1 $varName loaded
if {$loaded && !$unload} then {
set unload true
}
unset -nocomplain loaded
}
if {$unload} then {
set module [tcl module]
set interp [tcl master]
uplevel 1 [list tcl unload]
tputs $::test_channel [appendArgs \
"---- native Tcl " [expr {$force ? "forcibly " : ""}] \
"unloaded, module \"" $module "\", interpreter \"" \
$interp \"\n]
}
}
proc generateUniqueId { {text ""} {length 16} } {
#
# HACK: This should generate a reasonably random unique identifier
# suitable for non-cryptographic use by the test suite.
#
if {[string length $text] > 0} then {
return [string range \
[string tolower [hash normal sha512 $text]] 0 $length]
} else {
return [string range \
[string tolower [hash normal sha512 [appendArgs uniq \
[info context] [info tid] [pid] [clock clicks] [clock \
now]]]] 0 $length]
}
}
proc testExecTclScript { script {shell ""} {verbose 0} } {
try {
#
# NOTE: Get a temporary file name for the script we are going to
# use to query the machine type for the native Tcl shell.
#
set fileName [file tempname]
#
# NOTE: Since the native Tcl shell cannot simply evaluate a string
# supplied via the command line, write the script to be
# evaluated to the temporary file.
#
writeFile $fileName $script
#
# NOTE: Use the specified shell, if it is valid; otherwise, use
# the configured Tcl shell.
#
if {[string length $shell] == 0} then {
#
# NOTE: Before attempting to use the configured Tcl shell, make
# sure it has actually been set.
#
if {[info exists ::test_tclsh] && \
[string length $::test_tclsh] > 0} then {
#
# NOTE: Use the currently configured Tcl shell, which may or
# may not actually exist.
#
set shell $::test_tclsh
} else {
#
# NOTE: We cannot execute the native Tcl shell because one
# has not been specified, nor configured.
#
set error "error: \"::test_tclsh\" variable is missing"
if {$verbose > 0} then {
tputs $::test_channel [appendArgs \
"---- native Tcl script error: " $error \n]
}
return [expr {$verbose > 3 ? $error : "error"}]
}
}
#
# NOTE: Generate a unique identifier to make it easier to locate
# this script and its results in the test log file.
#
if {$verbose > 1} then {
set id [generateUniqueId $script]
}
#
# NOTE: When in "ultra-verbose" mode, emit native Tcl script to
# the log file.
#
if {$verbose > 2} then {
tputs $::test_channel [appendArgs \
"---- native Tcl script (" $id ") text: " [string trim \
$script] \n]
}
#
# NOTE: Evaluate the script using the native Tcl shell, trim the
# excess whitespace from the output, and return it to the
# caller.
#
if {[catch {string trim \
[testExec $shell [list -success Success] \
[appendArgs \" $fileName \"]]} result] == 0} then {
#
# NOTE: When in "super-verbose" mode, emit native Tcl script
# results to the log file.
#
if {$verbose > 1} then {
tputs $::test_channel [appendArgs \
"---- native Tcl script (" $id ") result: " $result \n]
}
#
# NOTE: Success, return the result to the caller.
#
return $result
} else {
#
# NOTE: We could not execute the native Tcl shell (perhaps one
# is not available?).
#
set error [appendArgs "error: " $result]
if {$verbose > 0} then {
tputs $::test_channel [appendArgs \
"---- native Tcl script error: " $error \n]
}
return [expr {$verbose > 3 ? $error : "error"}]
}
} finally {
#
# NOTE: Should we delete the temporary file we created, if any?
#
if {![info exists ::no(deleteTestExecTclFile)]} then {
#
# NOTE: Did we create a temporary file to hold the Tcl script?
#
if {[info exists fileName] && \
[string length $fileName] > 0 && \
[file exists $fileName]} then {
#
# NOTE: Delete the temporary file we used to query the machine
# type for the native Tcl shell.
#
catch {file delete $fileName}
}
}
}
}
proc getTclShellVerbosity {} {
if {[info exists ::test_tclsh_verbose] && \
[string is integer -strict $::test_tclsh_verbose]} then {
return $::test_tclsh_verbose
} else {
return 0; # TODO: Good default?
}
}
proc getTclVersionForTclShell { {shell ""} {verbose 0} } {
return [testExecTclScript {
puts -nonewline stdout [info tclversion]
} $shell $verbose]
}
proc getCommandsForTclShell { {shell ""} {verbose 0} } {
return [testExecTclScript {
puts -nonewline stdout [info commands]
} $shell $verbose]
}
proc getMachineForTclShell { {shell ""} {verbose 0} } {
return [testExecTclScript {
puts -nonewline stdout $tcl_platform(machine)
} $shell $verbose]
}
proc getTclExecutableForTclShell { {shell ""} {verbose 0} } {
return [testExecTclScript {
puts -nonewline stdout [info nameofexecutable]
} $shell $verbose]
}
proc getTkVersionForTclShell { {shell ""} {verbose 0} } {
return [testExecTclScript {
puts -nonewline stdout [package require Tk]; exit
} $shell $verbose]
}
proc evalWithTclShell { script {raw false} {shell ""} {verbose 0} } {
return [testExecTclScript [string map \
[list %script% $script %raw% $raw] {
if {%raw%} then {
set code [catch {%script%} result]
puts -nonewline stdout [list $code $result]
} else {
puts -nonewline stdout [eval {%script%}]
}
}] $shell $verbose]
}
proc getGarudaDll { {machine ""} } {
#
# NOTE: Get the Garuda DLL of the same platform (i.e. machine type)
# as the native Tcl shell.
#
if {[info exists ::base_path]} then {
#
# NOTE: Get the effective test configuration.
#
set configuration [getTestConfiguration]
#
# NOTE: If there is no effective test configuration available, we
# cannot continue.
#
if {[string length $configuration] == 0} then {
return ""
}
#
# NOTE: Get the effective test suffix. This is allowed to be an
# empty string.
#
set suffix [getTestSuffix]
#
# NOTE: If necessary, automatically detect the machine for the Tcl
# shell that we plan on using.
#
if {[string length $machine] == 0 && \
![info exists ::no(getMachineForTclShell)]} then {
set machine [getMachineForTclShell "" [getTclShellVerbosity]]
}
#
# NOTE: Build the full path and file name of the Garuda DLL, using
# the Eagle base path. Currently, this will only work
# correctly if the test suite is being run from inside the
# source tree.
#
return [file join $::base_path bin \
[machineToPlatform $machine] [appendArgs $configuration Dll \
$suffix] [appendArgs Garuda [info sharedlibextension]]]
} else {
#
# NOTE: We are missing the base path, return nothing.
#
return ""
}
}
proc cleanupExcel {} {
#
# TODO: These may need to be changed in later Excel versions.
#
object undeclare -declarepattern Microsoft.Office.Interop.Excel*
object unimport -importpattern Microsoft.Office.Interop.Excel
}
proc cleanupVisualBasic {} {
#
# TODO: These may need to be changed in later framework versions.
#
object unimport -importpattern Microsoft.VisualBasic*
}
proc cleanupXml {} {
#
# TODO: These may need to be changed in later framework versions.
#
object unimport -importpattern System.Xml*
}
proc cleanupWinForms {} {
#
# TODO: These may need to be changed in later framework versions.
#
object unimport -importpattern System.Resources
object unimport -importpattern System.Windows.Forms
object unimport -importpattern System.Windows.Forms.Automation
object unimport -importpattern \
System.Windows.Forms.ComponentModel.Com2Interop
object unimport -importpattern System.Windows.Forms.Design
object unimport -importpattern System.Windows.Forms.Layout
object unimport -importpattern System.Windows.Forms.PropertyGridInternal
object unimport -importpattern System.Windows.Forms.VisualStyles
}
proc getTestLibraryDirectory {} {
#
# NOTE: First, query the location of the script library. This will
# not work right in a "safe" interpreter.
#
if {[catch {info library} result] == 0} then {
#
# NOTE: Next, If the script library is embedded within the core
# library itself (i.e. the script library location refers
# to a file, not a directory), strip off the file name.
#
if {[file exists $result] && [file isfile $result]} then {
set result [file dirname $result]
}
#
# NOTE: Finally, return the resulting script library directory.
#
return $result
}
return ""
}
#
# NOTE: Check for the test path in the various well-known locations
# and set the associated variable.
#
if {![info exists ::no(checkForAndSetTestPath)]} then {
checkForAndSetTestPath false [expr {![isTestSuiteRunning]}]
}
#
# NOTE: Fake loading and configuring the "tcltest" package unless we
# are prevented.
#
if {![info exists ::no(configureTcltest)]} then {
configureTcltest "" [list] [list] [list] [list] false
}
###########################################################################
############################# END Eagle ONLY ##############################
###########################################################################
} else {
###########################################################################
############################# BEGIN Tcl ONLY ##############################
###########################################################################
proc getPassedPercentage {} {
if {$::tcltest::numTests(Total) > 0} then {
return [expr \
{100.0 * (($::tcltest::numTests(Passed) + \
$::tcltest::numTests(Skipped)) / \
double($::tcltest::numTests(Total)))}]
}
return 0; # no tests were run, etc.
}
proc getSkippedPercentage {} {
if {$::tcltest::numTests(Total) > 0} then {
return [expr \
{100.0 * ($::tcltest::numTests(Skipped) / \
double($::tcltest::numTests(Total)))}]
}
return 0; # no tests were run, etc.
}
#
# NOTE: Check for the test path in the various well-known locations
# and set the associated variable.
#
if {![info exists ::no(checkForAndSetTestPath)]} then {
checkForAndSetTestPath false [expr {![isTestSuiteRunning]}]
}
#
# NOTE: Load and configure the "tcltest" package unless we are prevented.
#
if {![info exists ::no(configureTcltest)]} then {
configureTcltest "" [list] [list] [list] [list test testConstraint] false
}
#
# NOTE: We need several of our test related commands in the global
# namespace as well.
#
exportAndImportPackageCommands [namespace current] [list \
dumpState trawputs tputs ttclLog doesTestLogFileExist \
getTestLogStartSentry extractTestRunIdFromLogStartSentry \
doesTestLogHaveStartSentry didTestLogHaveStartSentry \
setTestLogStartSentry tlog getSoftwareRegistryKey haveConstraint \
addConstraint haveOrAddConstraint getConstraints getCachedConstraints \
useCachedConstraints removeConstraint fixConstraints \
fixTimingConstraints testDebugBreak testArrayGet testArrayGet2 \
testResultGet testValueGet getFirstLineOfError calculateBogoCops \
calculateRelativePerformance formatTimeStamp formatElapsedTime \
sourceIfValid processTestArguments getTclShellFileName \
getTemporaryPath getTemporaryFileName getFiles getTestFiles \
getTestRunId getNewTestRunId getDefaultTestLogPath getTestLogPath \
getTestLogId getDefaultTestLog getTestLog getLastTestLog \
getTestSuite getTestSuiteFullName getTestMachine getTestPlatform \
getTestConfiguration getTestNamePrefix getTestSuffix \
getTestUncountedLeaks getRuntimeAssemblyName getTestAssemblyName \
canTestExec testExec testClrExec execTestShell isRandomOrder \
isBreakOnDemand isBreakOnLeak isStopOnFailure isStopOnLeak \
isExitOnComplete returnInfoScript runTestPrologue runTestEpilogue \
hookPuts unhookPuts runTest testShim tsource recordTestStatistics \
reportTestStatistics formatList formatListAsDict pathToRegexp \
assemblyNameToRegexp inverseLsearchGlob removePathFromFileNames \
formatDecimal clearTestPercent reportTestPercent reportArrayGet \
reportTestStatisticCounts runAllTests isTestSuiteRunning \
getTestChannelOrDefault tryVerifyTestPath checkForAndSetTestPath \
configureTcltest machineToPlatform architectureForPlatform \
getPassedPercentage getSkippedPercentage] false false
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: Provide the Eagle "test" package to the interpreter.
#
package provide Eagle.Test \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}
