###############################################################################
#
# constraints.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Test Constraints 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 getKnownCompileOptions {} {
return [list \
APPDOMAINS APPROVED_VERBS ARM ASSEMBLY_RELEASE \
ASSEMBLY_STRONG_NAME_TAG ASSEMBLY_TAG ASSEMBLY_TEXT ASSEMBLY_URI \
BREAK_ON_EXITING BREAKPOINTS CACHE_ARGUMENT_TOSTRING \
CACHE_ARGUMENTLIST_TOSTRING CACHE_DICTIONARY CACHE_RESULT_TOSTRING \
CACHE_STATISTICS CACHE_STRINGLIST_TOSTRING CALLBACK_QUEUE CAS_POLICY \
CODE_ANALYSIS COM_TYPE_CACHE CONSOLE DAEMON DATA DEAD_CODE DEBUG \
DEBUGGER DEBUGGER_ARGUMENTS DEBUGGER_ENGINE DEBUGGER_EXECUTE \
DEBUGGER_EXPRESSION DEBUGGER_VARIABLE DEBUG_TRACE DEBUG_WRITE DRAWING \
DYNAMIC EAGLE EMBEDDED_LIBRARY EXECUTE_CACHE EXPRESSION_FLAGS \
FAST_ERRORCODE FAST_ERRORINFO HAVE_SIZEOF HISTORY IA64 \
INTERACTIVE_COMMANDS INTERNALS_VISIBLE_TO ISOLATED_INTERPRETERS \
ISOLATED_PLUGINS LIBRARY LICENSING LIST_CACHE MONO MONO_BUILD \
MONO_HACKS MONO_LEGACY NATIVE NATIVE_PACKAGE NATIVE_UTILITY \
NATIVE_UTILITY_BSTR NETWORK NET_20 NET_20_FAST_ENUM NET_20_ONLY \
NET_20_SP1 NET_20_SP2 NET_30 NET_35 NET_40 NET_45 NET_451 NET_452 \
NON_WORKING_CODE NOTIFY NOTIFY_ACTIVE NOTIFY_ARGUMENTS \
NOTIFY_EXCEPTION NOTIFY_EXECUTE NOTIFY_EXPRESSION NOTIFY_GLOBAL \
NOTIFY_OBJECT OBSOLETE OFFICIAL PARSE_CACHE PATCHLEVEL POLICY_TRACE \
PREVIOUS_RESULT RANDOMIZE_ID REMOTING SAMPLE SERIALIZATION \
SHARED_ID_POOL SHELL SOURCE_ID SOURCE_TIMESTAMP STATIC TCL TCL_KITS \
TCL_THREADED TCL_THREADS TCL_UNICODE TCL_WRAPPER TEST THREADING \
THROW_ON_DISPOSED TRACE TYPE_CACHE UNIX VERBOSE WEB WINDOWS WINFORMS \
WIX_30 WIX_35 WIX_36 WIX_37 WIX_38 X64 X86 XML]
}
proc getKnownMonoVersions {} {
#
# NOTE: This job of this procedure is to return the list of "known"
# versions of Mono supported by the test suite infrastructure.
#
return [list \
[list 2 0] [list 2 2] [list 2 4] [list 2 6] [list 2 8] [list 2 10] \
[list 2 11] [list 2 12] [list 3 0] [list 3 1] [list 3 2] [list 3 3] \
[list 3 4] [list 3 5] [list 3 6]]
}
#
# NOTE: This procedure was adapted from the one listed on the Tcl Wiki page
# at "http://wiki.tcl.tk/43". It is only intended to be used on very
# small lists because of its heavy use of recursion and complexity on
# the order of O(N!).
#
proc lpermute { list } {
set length [llength $list]
if {$length < 2} {
return [list $list]
}
set index 0
foreach element1 $list {
if {$index == 0} then {
set rest [lrange $list 1 end]
} elseif {$index == $length - 1} then {
set rest [lrange $list 0 end-1]
} else {
set rest [concat \
[lrange $list 0 [expr {$index - 1}]] \
[lrange $list [expr {$index + 1}] end]]
}
incr index
foreach list2 [lpermute $rest] {
lappend result [concat [list $element1] $list2]
}
}
return $result
}
proc alwaysFullInterpReady {} {
#
# NOTE: The [interp readylimit] sub-command is only in Eagle.
#
if {![isEagle]} then {
return true
}
#
# NOTE: If this Eagle version lacks [interp readylimit] -OR- it has
# the default value (i.e. it always fully checks readiness),
# return true.
#
return [expr {
[catch {interp readylimit {}} readylimit] != 0 || $readylimit == 0
}]
}
#
# NOTE: This procedure should return non-zero if the native Tcl shell may
# be executed by the test suite infrastructure outside the context
# of any specific tests. The specific tests themselves must make
# use of their own constraints to prevent execution of the native
# Tcl shell.
#
proc canExecTclShell {} {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(tcl)]} then {
return false
}
if {[info exists ::no(canExecTclShell)]} then {
return false
}
return true
}
#
# NOTE: This procedure should return non-zero if Fossil may be executed by
# the test suite infrastructure outside the context of any specific
# tests. The specific tests themselves must make use of their own
# constraints to prevent execution of Fossil.
#
proc canExecFossil {} {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(fossil)]} then {
return false
}
if {[info exists ::no(canExecFossil)]} then {
return false
}
return true
}
proc checkForTestSuiteFiles { channel } {
tputs $channel "---- checking for test suite files... "
#
# NOTE: Start out with no test suite files to check.
#
set fileNames [list]
#
# NOTE: Check if the base package path is available.
#
if {[info exists ::test_package_path]} then {
#
# TODO: If additional test suite files are added within the base
# package path, add them here as well.
#
foreach fileNameOnly [list \
embed.eagle init.eagle pkgIndex.eagle pkgIndex.tcl \
safe.eagle shell.eagle test.eagle vendor.eagle word.tcl] {
#
# NOTE: First, check if the file resides in the Eagle-specific
# package sub-directory. Failing that, fallback to using
# the base package path itself.
#
set fileName [file join \
$::test_package_path Eagle1.0 $fileNameOnly]
if {![file exists $fileName]} then {
set fileName [file join $::test_package_path $fileNameOnly]
}
#
# NOTE: If the test suite file exists, add it to the list of file
# names to process.
#
if {[file exists $fileName]} then {
lappend fileNames $fileName
}
}
}
#
# NOTE: Check if the test package path is available.
#
if {[info exists ::test_path]} then {
#
# TODO: If additional test suite files are added within the test
# package path, add them here as well.
#
foreach fileNameOnly [list \
all.eagle constraints.eagle epilogue.eagle pkgIndex.eagle \
pkgIndex.tcl prologue.eagle] {
#
# NOTE: Check if the file resides in the test package directory.
#
set fileName [file join $::test_path $fileNameOnly]
#
# NOTE: If the test suite file exists, add it to the list of file
# names to process.
#
if {[file exists $fileName]} then {
lappend fileNames $fileName
}
}
}
#
# NOTE: Did we find any test suite files?
#
if {[llength $fileNames] > 0} then {
#
# NOTE: Eagle has a built-in hashing command; however, Tcl requires
# a package. Make sure we can hash content before proceeding.
#
if {[isEagle] || [catch {package require sha1}] == 0} then {
tputs $channel yes\n
foreach fileName $fileNames {
if {[isEagle]} then {
#
# NOTE: Use the relatively new -filename option to the Eagle
# [hash] command.
#
set sha1 [hash normal -filename sha1 $fileName]
} else {
#
# BUGBUG: Apparently, the ActiveState tcllib sha1 package may
# have a bug that produces the wrong values here. No
# attempt is made here to work around any such bug.
# For further information, please see:
#
# http://core.tcl.tk/tcllib/info/ad20454023
#
set sha1 [sha1::sha1 -hex -filename $fileName]
}
tputs $channel [appendArgs \
"---- file \"" $fileName "\"... sha1 (" $sha1 ")\n"]
}
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForPlatform { channel } {
tputs $channel "---- checking for platform... "
if {[info exists ::tcl_platform(platform)]} then {
addConstraint $::tcl_platform(platform)
tputs $channel [appendArgs $::tcl_platform(platform) \n]
} else {
tputs $channel unknown\n
}
###########################################################################
if {![isEagle]} then {
#
# BUGFIX: We do not normally want to skip any Mono bugs in native Tcl.
#
if {![info exists ::no(runtimeVersion)]} then {
#
# NOTE: Add the necessary constraints for each version of Mono that
# we know about.
#
foreach monoVersion [getKnownMonoVersions] {
set constraintVersion [join $monoVersion ""]
addConstraint [appendArgs monoToDo $constraintVersion]
addConstraint [appendArgs monoToDo $constraintVersion Only]
addConstraint [appendArgs monoBug $constraintVersion]
addConstraint [appendArgs monoBug $constraintVersion Only]
addConstraint [appendArgs monoCrash $constraintVersion]
addConstraint [appendArgs monoCrash $constraintVersion Only]
}
#
# NOTE: Also add just the generic Mono constraints that do not have
# a trailing version.
#
set constraints [list monoToDo monoBug monoCrash]
foreach constraint $constraints {
addConstraint $constraint
}
}
}
}
proc checkForWindowsVersion { channel } {
tputs $channel "---- checking for Windows version... "
#
# NOTE: Are we running on Windows at all?
#
if {[isWindows]} then {
#
# NOTE: Is the specific OS name and version number available?
#
if {[info exists ::tcl_platform(os)] && \
[string length $::tcl_platform(os)] > 0 && \
[info exists ::tcl_platform(osVersion)] && \
[string length $::tcl_platform(osVersion)] > 0 && \
[regexp -- {^\d+\.\d+$} $::tcl_platform(osVersion)]} then {
#
# NOTE: Start out with the OS name, removing all spaces.
#
set version [appendArgs \
[string map [list " " ""] $::tcl_platform(os)] _ \
$::tcl_platform(osVersion)]
#
# NOTE: Add constraint containing the OS name and version number.
#
addConstraint [appendArgs osVersion. $version]
#
# NOTE: Show what we found for the OS name and version number.
#
tputs $channel [appendArgs "yes (" $::tcl_platform(os) " v" \
$::tcl_platform(osVersion) ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForScriptLibrary { channel } {
tputs $channel "---- checking for script library... "
#
# NOTE: See if the variable containing the script library location
# exists.
#
if {[info exists ::tcl_library] && \
[string length $::tcl_library] > 0} then {
#
# NOTE: Now see if the script library is external or embedded.
#
if {[file isdirectory $::tcl_library]} then {
#
# NOTE: Yes, it appears to be a directory name, which should
# mean that the necessary files are physically contained
# within it.
#
addConstraint tcl_library_external
tputs $channel "yes (external)\n"
#
# NOTE: We are done here, return now.
#
return
} elseif {[file isfile $::tcl_library]} then {
#
# NOTE: Yes, it appears to be a file name, which should mean
# that the necessary files are physically embedded within
# it.
#
addConstraint tcl_library_embedded
tputs $channel "yes (embedded)\n"
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForVariable { channel name {notEmpty true} {constraint ""} } {
tputs $channel [appendArgs "---- checking for variable \"" $name \
"\"... "]
#
# NOTE: First, normalize the variable name to be in the global scope.
#
set newName [appendArgs :: [string trimleft $name :]]
#
# NOTE: Next, always check if it actually exists (as of right now).
#
if {[info exists $newName]} then {
#
# NOTE: Next, optionally check if it constains anything.
#
if {!$notEmpty || [string length [set $newName]] > 0} then {
#
# NOTE: The variable exists and it either contains something
# or we do not care about its contents.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs variable_ $constraint]
} else {
addConstraint [appendArgs variable_ [string trimleft $newName :]]
}
#
# NOTE: Show that we found the variable and whether it actually
# contained anything.
#
tputs $channel [appendArgs "yes (" \
[expr {$notEmpty ? "exists, not empty" : "exists"}] ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForTclOptions { channel } {
tputs $channel "---- checking for Tcl options... "
if {![isEagle]} then {
set result [list]
#
# NOTE: This test constraint is needed by test "benchmark-1.22".
#
if {![info exists ::no(compileNative)]} then {
lappend result compile.NATIVE
addConstraint compile.NATIVE
}
#
# NOTE: This test constraint is needed by test "benchmark-1.22".
#
if {![info exists ::no(compileWindows)]} then {
#
# NOTE: If the current platform is Windows the Tcl binary must have
# been compiled for Windows.
#
if {[isWindows]} then {
lappend result compile.WINDOWS
addConstraint compile.WINDOWS
}
}
#
# NOTE: This test constraint is needed by tests "socket-*.*".
#
if {![info exists ::no(compileNetwork)]} then {
lappend result compile.NETWORK
addConstraint compile.NETWORK
}
#
# NOTE: Just fake the invariant culture when running in native Tcl.
#
if {![info exists ::no(culture)]} then {
lappend result culture.invariant
addConstraint culture.invariant
}
tputs $channel [appendArgs "yes (" $result ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForWindowsCommandProcessor { channel pattern {constraint ""} } {
tputs $channel "---- checking for Windows Command Processor... "
if {[isWindows]} then {
#
# NOTE: Grab the "ComSpec" from the Windows environment and make sure it
# matches the file pattern supplied by the caller (e.g. "cmd.exe").
#
if {[info exists ::env(ComSpec)] && \
[string match -nocase $pattern [file tail $::env(ComSpec)]]} then {
#
# NOTE: We are running with a matching command processor.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs comSpec_ $constraint]
} else {
addConstraint [appendArgs comSpec_ \
[string map [list * _ - _ ? _ \[ _ \\ _ \] _] $pattern]]
}
tputs $channel [appendArgs "yes (\"" $::env(ComSpec) "\")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForFossil { channel } {
tputs $channel "---- checking for Fossil... "
if {[canExecFossil] && \
[catch {exec -- fossil version} version] == 0} then {
set version [string trim $version]
set pattern {^This is fossil version (.*) \[([0-9a-f]+)\]\
\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2} UTC$}
if {[regexp -- $pattern $version dummy version sourceId]} then {
#
# NOTE: Add a constraint to show that the Fossil executable
# itself is available.
#
addConstraint fossil_version
#
# NOTE: Append the version of Fossil currently in use.
#
append result version " " $version " \[" $sourceId \]
if {[canExecFossil] && \
[catch {exec -- fossil remote} remote] == 0} then {
set remote [string trim $remote]; set valid false
if {[isEagle]} then {
#
# NOTE: With Eagle, we can actually validate the URI.
#
if {[uri isvalid $remote]} then {
set valid true
}
} else {
#
# HACK: Currently, there is no simple way to validate
# an arbitrary URI with Tcl (i.e. without using
# some hideously complex regular expression).
#
if {[string length $remote] > 0} then {
set valid true
}
}
if {$valid} then {
#
# NOTE: Add a constraint to show that a valid Fossil
# repository URI appears to be available.
#
addConstraint fossil_repository
#
# NOTE: If we are not prevented from doing so, save the
# test repository to the repository URI currently
# in use to a suitably named global variable.
#
if {![info exists ::no(setRepository)]} then {
set ::test_repository $remote
}
#
# NOTE: Append the repository URI currently in use.
#
append result ", repository \"" $remote \"
#
# NOTE: Show the result of the checking.
#
tputs $channel [appendArgs "yes (" $result ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
}
}
tputs $channel no\n
}
proc checkForEagle { channel } {
tputs $channel "---- checking for Eagle... "
if {[isEagle]} then {
#
# NOTE: We are running inside Eagle.
#
addConstraint eagle
#
# NOTE: We do not want to skip bugs or crashing
# issues for Tcl since we are not running
# in Tcl.
#
addConstraint tclBug
addConstraint tclCrash
#
# NOTE: Add the necessary constraints for each
# version of Tcl we know about.
#
foreach version [list 84 85 86] {
addConstraint [appendArgs tclBug $version]
addConstraint [appendArgs tclCrash $version]
}
tputs $channel yes\n
} else {
#
# NOTE: We are running inside Tcl.
#
addConstraint tcl
#
# NOTE: Each Tcl bug and crash constraint is set
# based on the exact Tcl version (i.e. not
# greater than or equal to).
#
if {[info exists ::tcl_version]} then {
#
# NOTE: For each Tcl version we know about,
# check it against the currently running
# Tcl version. If the two are not equal,
# add the test constraints that prevent
# skipping those tests that are buggy
# only for the particular version of Tcl.
#
foreach dotVersion [list 8.4 8.5 8.6] {
if {$::tcl_version ne $dotVersion} then {
set version [string map [list . ""] $dotVersion]
addConstraint [appendArgs tclBug $version]
addConstraint [appendArgs tclCrash $version]
}
}
}
#
# NOTE: We do not want to skip bugs or crashing
# issues for Eagle since we are not running
# in Eagle.
#
addConstraint eagleBug
addConstraint eagleCrash
tputs $channel no\n
}
}
proc checkForSymbols { channel name {constraint ""} } {
set fileName [file normalize [appendArgs [file rootname $name] .pdb]]
tputs $channel [appendArgs "---- checking for symbols \"" $fileName \
"\"... "]
if {[file exists $fileName]} then {
#
# NOTE: The file appears to have associated symbols available.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs symbols_ $constraint]
} else {
addConstraint [appendArgs symbols_ [file tail $name]]
}
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForLogFile { channel } {
tputs $channel "---- checking for log file... "
if {[info exists ::test_log] && \
[string length $::test_log] > 0 && \
[file exists $::test_log]} then {
#
# NOTE: The log file appears to be available.
#
addConstraint logFile
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForGaruda { channel } {
tputs $channel "---- checking for Garuda... "
if {[haveGaruda packageId]} then {
#
# NOTE: We are running with or via Garuda.
#
addConstraint garuda
tputs $channel [appendArgs "yes (" $packageId ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForShell { channel } {
tputs $channel "---- checking for shell... "
set name [file rootname [file tail [info nameofexecutable]]]
if {[isEagle]} then {
if {$name eq "EagleShell"} then {
#
# NOTE: We are running in Eagle via the EagleShell.
#
addConstraint shell
tputs $channel "yes (Eagle)\n"
#
# NOTE: We are done here, return now.
#
return
}
} else {
if {[string match tclsh* $name]} then {
#
# NOTE: We are running in Tcl via tclsh.
#
addConstraint shell
tputs $channel "yes (Tcl)\n"
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForDebug { channel } {
tputs $channel "---- checking for debug... "
if {[info exists ::tcl_platform(debug)] && $::tcl_platform(debug)} then {
addConstraint debug
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTk { channel } {
tputs $channel "---- checking for Tk... "
#
# HACK: For now, disable testing Tk 8.4/8.5 when running in Eagle.
#
if {![isEagle] || [haveConstraint tclLibrary86]} then {
addConstraint tk
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForVersion { channel } {
tputs $channel "---- checking for language version... "
if {[info exists ::tcl_version]} then {
#
# TODO: Cleanup the semantics for adding test
# constraints here.
#
if {$::tcl_version eq "8.4"} then {
#
# NOTE: Baseline reported language and feature
# version.
#
addConstraint tcl84
addConstraint tcl84Feature
addConstraint tcl84OrLower
addConstraint tcl84OrHigher
addConstraint tcl85OrLower
if {[isEagle]} then {
#
# NOTE: *EAGLE* We do want to include any
# tests that target "Tcl 8.5 or higher"
# features and/or "Tcl 8.6 or higher"
# features because they would not be in
# the test suite if we did not support
# that particular feature, regardless
# of the language version.
#
addConstraint tcl85Feature
addConstraint tcl86Feature
}
} elseif {$::tcl_version eq "8.5"} then {
#
# NOTE: Baseline reported language and feature
# version. Tcl 8.5 includes all the
# features from itself and Tcl 8.4.
#
addConstraint tcl84Feature
addConstraint tcl84OrHigher
addConstraint tcl85
addConstraint tcl85Feature
addConstraint tcl85OrLower
addConstraint tcl85OrHigher
if {[isEagle]} then {
#
# NOTE: *EAGLE* We do want to include any
# tests that target "Tcl 8.5 or higher"
# features and/or "Tcl 8.6 or higher"
# features because they would not be in
# the test suite if we did not support
# that particular feature, regardless
# of the language version.
#
addConstraint tcl86Feature
}
} elseif {$::tcl_version eq "8.6"} then {
#
# NOTE: Baseline reported language and feature
# version. Tcl 8.6 includes all the
# features from itself Tcl 8.4, and Tcl
# 8.5.
#
addConstraint tcl84Feature
addConstraint tcl84OrHigher
addConstraint tcl85Feature
addConstraint tcl85OrHigher
addConstraint tcl86
addConstraint tcl86Feature
addConstraint tcl86OrLower
addConstraint tcl86OrHigher
}
tputs $channel [appendArgs $::tcl_version \n]
} else {
tputs $channel no\n
}
}
proc checkForCommand { channel name } {
tputs $channel [appendArgs "---- checking for command \"" $name \
"\"... "]
#
# NOTE: Is the command available?
#
if {[llength [info commands $name]] > 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs command. $name]
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForNamespaces { channel quiet } {
tputs $channel "---- checking for namespace support... "
if {[isEagle]} then {
#
# NOTE: Check if namespace support was compiled into the core library
# (i.e. this is beta 30 or later).
#
set available false
if {[catch {string length [object invoke \
Type GetType Eagle._Commands.Namespace2]} length] == 0 && \
[set available [expr {$length > 0}]]} then {
addConstraint namespaces.available
} else {
addConstraint namespaces.unavailable
}
if {[catch {object invoke -flags +NonPublic Interpreter.GetActive \
AreNamespacesEnabled} enabled] == 0} then {
#
# NOTE: We were able to query for namespace support (i.e. this
# must be beta 29 or later); however, we still need to
# check if it has been enabled at runtime.
#
if {$enabled} then {
#
# NOTE: Yes, it appears that it is available and enabled.
#
addConstraint namespaces
tputs $channel enabled\n
} else {
tputs $channel disabled\n
#
# NOTE: Check if namespace support was compiled into the core
# library (i.e. is this beta 30 or later).
#
if {!$quiet && $available} then {
#
# NOTE: The tests seem to be running with namespace support
# available, but disabled. Emit a warning into the
# test log file.
#
tputs $channel \
"==== WARNING: running with namespaces available and disabled\n"
}
}
} else {
tputs $channel error\n
}
} else {
#
# NOTE: All supported versions of native Tcl have namespaces enabled
# and available.
#
addConstraint namespaces.available
addConstraint namespaces
tputs $channel enabled\n
}
}
proc checkForTestExec { channel quiet } {
tputs $channel "---- checking for test use of \"exec\" command... "
set procName [lindex [info level [info level]] 0]
if {![info exists ::no(testExec)] && [canTestExec $procName]} then {
addConstraint testExec
tputs $channel yes\n
if {!$quiet && [info exists ::no(exec)]} then {
tputs $channel \
"==== WARNING: running with the \"testExec\" procedure disabled\n"
}
} else {
tputs $channel no\n
}
}
proc checkForTestMachine { channel } {
tputs $channel "---- checking for test machine... "
if {[info exists ::test_machine] && \
[string length $::test_machine] > 0} then {
addConstraint [appendArgs machine. $::test_machine]
tputs $channel [appendArgs $::test_machine \n]
} else {
tputs $channel unknown\n
}
}
proc checkForTestPlatform { channel } {
tputs $channel "---- checking for test platform... "
if {[info exists ::test_platform] && \
[string length $::test_platform] > 0} then {
addConstraint [appendArgs platform. $::test_platform]
tputs $channel [appendArgs $::test_platform \n]
} else {
tputs $channel unknown\n
}
}
proc checkForTestConfiguration { channel } {
tputs $channel "---- checking for test configuration... "
if {[info exists ::test_configuration] && \
[string length $::test_configuration] > 0} then {
addConstraint [appendArgs configuration. $::test_configuration]
tputs $channel [appendArgs $::test_configuration \n]
} else {
tputs $channel unknown\n
}
}
proc checkForTestSuffix { channel } {
tputs $channel "---- checking for test suffix... "
if {[info exists ::test_suffix] && \
[string length $::test_suffix] > 0} then {
addConstraint [appendArgs suffix. $::test_suffix]
tputs $channel [appendArgs $::test_suffix \n]
} else {
tputs $channel unknown\n
}
}
proc checkForFile { channel name {constraint ""} } {
tputs $channel [appendArgs "---- checking for file \"" \
[file normalize $name] "\"... "]
if {[file exists $name]} then {
#
# NOTE: Yes, it appears that it is available.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs file_ $constraint]
} else {
addConstraint [appendArgs file_ [file tail $name]]
}
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForPathFile { channel name {constraint ""} } {
tputs $channel [appendArgs "---- checking for file \"" $name \
"\" along PATH... "]
if {[file exists $name]} then {
#
# NOTE: Yes, it appears that it is available [in the exact location they
# specified].
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs file_ $constraint]
} else {
addConstraint [appendArgs file_ [file tail $name]]
}
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
} else {
#
# NOTE: Use the appropriate environment variable for the platform.
#
if {[isWindows]} then {
set pathName PATH
} else {
#
# HACK: For shared libraries, use the LD_LIBRARY_PATH.
#
if {[file extension $name] eq [info sharedlibextension]} then {
set pathName LD_LIBRARY_PATH
} else {
set pathName PATH
}
}
#
# NOTE: Is the required environment variable available?
#
if {[info exists ::env($pathName)]} then {
#
# NOTE: Ok, grab it now.
#
set path $::env($pathName)
#
# NOTE: Use the appropriate path separator for the platform.
#
if {[info exists ::tcl_platform(pathSeparator)]} then {
set separator $::tcl_platform(pathSeparator)
} elseif {[isWindows]} then {
set separator \;
} else {
set separator :
}
#
# NOTE: Grab just the file name from the possibly fully qualified file
# name provided by the caller.
#
set tail [file tail $name]
#
# NOTE: Check each directory in the PATH for the file.
#
foreach directory [split $path $separator] {
#
# NOTE: Check for the file in this directory contained in the PATH.
# This strips the directory portion off the file name specified
# by the caller, if any, before joining that file name to the
# current directory of the PATH being searched.
#
if {[file exists [file join $directory $tail]]} then {
#
# NOTE: Yes, it appears that it is available in the PATH.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs file_ $constraint]
} else {
addConstraint [appendArgs file_ [file tail $name]]
}
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
}
}
tputs $channel no\n
}
proc checkForNativeCode { channel } {
tputs $channel "---- checking for native code... "
if {[isEagle]} then {
if {[info exists ::eagle_platform(compileOptions)] && \
[info exists ::tcl_platform(platform)] && \
[lsearch -exact -nocase $::eagle_platform(compileOptions) \
$::tcl_platform(platform)] != -1} then {
#
# NOTE: Yes, the binary matches the current platform,
# native code can be used.
#
addConstraint native
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
#
# NOTE: Tcl is always native code and can always execute native code.
#
addConstraint native
tputs $channel yes\n
}
}
proc checkForTip127 { channel } {
tputs $channel "---- checking for TIP #127... "
#
# NOTE: Is the interpreter TIP #127 ready?
#
if {[catch {lsearch -index 0 0 0}] == 0} then {
addConstraint tip127
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip194 { channel } {
tputs $channel "---- checking for TIP #194... "
#
# NOTE: Is the interpreter TIP #194 ready?
#
catch {apply} error
if {$error ne {invalid command name "apply"}} then {
addConstraint tip194
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip207 { channel } {
tputs $channel "---- checking for TIP #207... "
#
# NOTE: Is the interpreter TIP #207 ready?
#
catch {interp invokehidden {} -namespace -- info} error
if {![string match {bad option "-namespace": *} $error]} then {
addConstraint tip207
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip241 { channel } {
tputs $channel "---- checking for TIP #241... "
#
# NOTE: Is the interpreter TIP #241 ready?
#
if {[catch {lsearch -nocase 0 0}] == 0} then {
addConstraint tip241
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip285 { channel } {
tputs $channel "---- checking for TIP #285... "
if {[alwaysFullInterpReady]} then {
#
# NOTE: Is the interpreter TIP #285 ready?
#
catch {interp cancel} error
if {$error eq "eval canceled"} then {
addConstraint tip285
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForTip405 { channel } {
tputs $channel "---- checking for TIP #405... "
#
# NOTE: Does the interpreter have TIP #405 (i.e. [lmap])?
#
catch {lmap} error
if {$error ne "invalid command name \"lmap\""} then {
addConstraint tip405
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip426 { channel } {
tputs $channel "---- checking for TIP #426... "
#
# NOTE: Is the interpreter TIP #426 ready?
#
catch {info cmdtype} error
if {$error eq {wrong # args: should be "info cmdtype commandName"}} then {
addConstraint tip426
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip429 { channel } {
tputs $channel "---- checking for TIP #429... "
#
# NOTE: Is the interpreter TIP #429 ready?
#
if {[catch {string cat}] == 0} then {
addConstraint tip429
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTiming {
channel threshold {constraint ""} {tries 1} {delay 1000}
{average false} {asynchronous false} } {
tputs $channel [appendArgs \
"---- checking for precision timing (threshold of " $threshold \
" milliseconds" [expr {$average ? " average" : ""}] ", delay of " \
$delay " milliseconds)... "]
#
# HACK: Sometimes the first try takes quite a bit longer than subsequent
# tries. We attempt to bypass this problem by retrying a set number
# of times (which can be overridden by the caller) before giving up.
#
set total 0
set difference unknown
for {set try 0} {$try < $tries} {incr try} {
#
# NOTE: Create a script that will set the final clicks value. This must
# use a global variable due to the nature of [after].
#
set stopScript {
set ::stopClicks [expr {[clock clicks -milliseconds] & 0x7fffffff}]
}
#
# NOTE: Set the initial clicks value and then attempt to wait for about
# one second, either synchronously or asynchronously, depending on
# the preference of the caller.
#
set start [expr {[clock clicks -milliseconds] & 0x7fffffff}]
if {$asynchronous} then {
set event [after $delay $stopScript]; vwait ::stopClicks
} else {
after $delay; eval $stopScript
}
#
# NOTE: Move the final clicks value from the global frame to this one.
#
set stop $::stopClicks; unset ::stopClicks
#
# NOTE: Calculate the difference between the actual and expected
# number of milliseconds.
#
set difference [expr {abs($stop - $start - $delay)}]
#
# NOTE: Keep track of the total number of milliseconds elapsed for
# all iterations of this loop.
#
incr total $difference
#
# NOTE: If we are using the average difference, handle that now.
#
if {$average && $tries > 1} then {
set difference [expr {$total / $tries}]
}
#
# NOTE: Are we within the threshold specified by the caller?
#
if {$difference >= 0 && $difference <= $threshold} then {
#
# NOTE: We appear to be capable of fairly precise timing.
#
if {[string length $constraint] == 0} then {
set constraint timing
}
addConstraint $constraint
tputs $channel [appendArgs \
"yes (0 <= " $difference " <= " $threshold " milliseconds" \
[expr {$average ? " average" : ""}] ", tried " [expr {$try + 1}] \
" out of " $tries " " [expr {$tries > 1 ? "times" : "time"}] \
", \"" $constraint "\")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel [appendArgs \
"no (0 <= " $difference " > " $threshold " milliseconds" \
[expr {$average ? " average" : ""}] ", tried " $try " out of " \
$tries " " [expr {$tries > 1 ? "times" : "time"}] ")\n"]
}
proc checkForPerformance { channel } {
tputs $channel "---- checking for performance testing... "
#
# NOTE: Are we allowed to do performance testing?
#
if {![info exists ::no(performance)]} then {
addConstraint performance
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForBigLists { channel } {
tputs $channel "---- checking for big list testing... "
#
# NOTE: Are we allowed to do big list testing?
#
if {![info exists ::no(bigLists)]} then {
if {[isEagle]} then {
#
# MONO: Using the native utility library when running on Mono to
# join big lists seems to cause StackOverflowException to
# be thrown.
#
if {[info exists ::no(mono)] || ![isMono] || \
![haveConstraint nativeUtility]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint bigLists
tputs $channel yes\n
} else {
tputs $channel "no, broken on Mono with native utility\n"
}
} else {
addConstraint bigLists
tputs $channel yes\n
}
} else {
tputs $channel no\n
}
}
proc checkForMemoryIntensive { channel } {
tputs $channel "---- checking for memory intensive testing... "
#
# NOTE: Are we allowed to do memory intensive testing?
#
if {![info exists ::no(memoryIntensive)]} then {
addConstraint memoryIntensive
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForStackIntensive { channel } {
tputs $channel "---- checking for stack intensive testing... "
#
# NOTE: Are we allowed to do stack intensive testing?
#
if {![info exists ::no(stackIntensive)]} then {
if {[isEagle]} then {
#
# NOTE: Attempt to query for native stack checking in Eagle.
#
if {[catch {object invoke -flags +NonPublic \
Eagle._Components.Private.NativeStack CanQueryThread} \
canQueryThread] == 0 && \
$canQueryThread} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint stackIntensive
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
addConstraint stackIntensive
tputs $channel yes\n
}
} else {
tputs $channel no\n
}
}
proc checkForInteractive { channel } {
tputs $channel "---- checking for interactive user... "
#
# NOTE: Is there an interactive user?
#
if {[info exists ::tcl_interactive] && $::tcl_interactive} then {
addConstraint interactive
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForInteractiveCommand { channel name } {
tputs $channel [appendArgs "---- checking for interactive command \"" \
$name "\"... "]
#
# NOTE: Currently, only Eagle has "interactive commands".
#
if {[isEagle]} then {
#
# NOTE: Attempt to query the interactive command names from Eagle.
#
if {[catch {object invoke Utility GetInteractiveCommandNames $name \
false} names] == 0 && \
[llength $names] > 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs interactiveCommand. $name]
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForUserInteraction { channel } {
tputs $channel "---- checking for user interaction... "
#
# HACK: For now, do the exact same check as checkForInteractive; however,
# this is still useful as a separate constraint because it can be
# individually disabled in "prologue.eagle".
#
if {[info exists ::tcl_interactive] && $::tcl_interactive} then {
addConstraint userInteraction
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForNetwork { channel host timeout } {
tputs $channel [appendArgs \
"---- checking for network connectivity to host \"" $host "\"... "]
if {[isEagle]} then {
#
# NOTE: Running this check on the Mono 3.3.0 (or 3.4.0?) release build
# will lock up the process; therefore, skip it in that case.
#
if {[info exists ::no(mono)] || ![isMono] || \
(![haveConstraint mono33] && ![haveConstraint mono34])} 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 {[llength [info commands uri]] > 0 && \
[catch {uri ping $host $timeout} response] == 0 && \
[lindex $response 0] in [list Success TimedOut] && \
[string is integer -strict [lindex $response 1]] && \
[lindex $response 1] <= $timeout}
#
# NOTE: Does it look like we are able to contact the network host?
#
if {[expr $expr]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs network_ $host]
tputs $channel [appendArgs "yes (" $response ")\n"]
} else {
tputs $channel no\n
}
} else {
tputs $channel "skipped, may hang on Mono 3.3.0 and 3.4.0\n"
}
} else {
#
# HACK: Running in Tcl, just assume we have network access.
#
addConstraint [appendArgs network_ $host]
tputs $channel yes\n
}
}
proc checkForCompileOption { channel option } {
tputs $channel [appendArgs "---- checking for compile option \"" \
$option "\"... "]
if {[isEagle]} then {
if {[info exists ::eagle_platform(compileOptions)] && \
[lsearch -exact -nocase $::eagle_platform(compileOptions) \
$option] != -1} then {
#
# NOTE: Yes, support for the Eagle compile option is present.
#
addConstraint [appendArgs compile. $option]
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
#
# NOTE: We are running inside Tcl; however, we need to check for an
# Eagle compile option. This can now be accomplished via the
# [eagle] command supplied by the Eagle Package for Tcl, if
# it is actually loaded and available.
#
if {[llength [info commands eagle]] > 0} then {
set options [eagle [list expr {[info exists \
::eagle_platform(compileOptions)] ? \
$::eagle_platform(compileOptions) : [list]}]]
if {[lsearch -exact $options $option] != -1} then {
#
# NOTE: Yes, support for the Eagle compile option is present.
#
addConstraint [appendArgs compile. $option]
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
}
proc checkForKnownCompileOptions { channel } {
#
# NOTE: Check for all "known" compile options.
#
tputs $channel "---- checking for known compile options... "
set options [getKnownCompileOptions]
if {[llength $options] > 0} then {
tputs $channel [appendArgs "yes (" [llength $options] ")\n"]
foreach option $options {
if {![info exists [appendArgs ::no(compile. $option )]]} then {
checkForCompileOption $channel $option
}
}
} else {
tputs $channel no\n
}
}
if {[isEagle]} then {
###########################################################################
############################ BEGIN Eagle ONLY #############################
###########################################################################
proc checkForSoftwareUpdateTrust { channel } {
tputs $channel "---- checking for software update trust... "
if {[llength [info commands uri]] > 0 && \
[catch {uri softwareupdates} trust] == 0 && \
$trust eq "software update certificate is trusted"} then {
#
# NOTE: Yes, it appears that we trust our software updates.
# Since this setting is off by default, the user (or
# a script evaluated by the user) must have manually
# turned it on.
#
addConstraint softwareUpdate
tputs $channel trusted\n
} else {
tputs $channel untrusted\n
}
}
proc checkForManagedDebuggingAssistants { channel } {
set fileName [file normalize [appendArgs [info nameofexecutable] \
.mda.config]]
tputs $channel [appendArgs \
"---- checking for managed debugging assistants enabled via \"" \
$fileName "\"... "]
if {[file exists $fileName]} then {
#
# NOTE: Since the System.Xml assembly may not be loaded, wrap the
# detection in a [catch] block.
#
if {[catch {
#
# NOTE: Create and load an XML document based on the data from the
# MDA configuration file associated with the executable that
# started this process.
#
set document [object create -alias System.Xml.XmlDocument]
$document LoadXml [readFile $fileName]
#
# NOTE: Setup the XML namespace manager for use when using XPath
# to query the XML document.
#
set nameTable [$document NameTable]
set namespaceManager [object create \
-alias System.Xml.XmlNamespaceManager $nameTable]
$namespaceManager AddNamespace mda \
http://schemas.microsoft.com/CLR/2004/10/mda
#
# NOTE: Select all nodes underneath the location where they should
# reside in the MDA configuration XML document.
#
set nodes [$document SelectNodes \
/mda:mdaConfig/mda:assistants/* $namespaceManager]
#
# NOTE: Populate the local result variable with the names of
# all the XML nodes found.
#
set names [object lmap -alias node $nodes {
$node Name
}]
}] == 0} then {
#
# NOTE: Ok, the XML configuration file was loaded and parsed
# correctly, see if any managed debugging assistants were
# found enabled within it.
#
if {[info exists names] && [llength $names] > 0} then {
#
# NOTE: Add a test constraint for each managed debugging
# assistant that appears to be enabled.
#
addConstraint mda
foreach name $names {
addConstraint [appendArgs mda. $name]
}
#
# NOTE: Save the list of managed debugging assistants for
# later use by the test suite.
#
if {![info exists ::no(setMdas)]} then {
set ::test_mdas $names
}
#
# NOTE: Yes, it appears that at least one managed debugging
# assistant is enabled.
#
tputs $channel [appendArgs "yes (" $names ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
}
tputs $channel no\n
}
proc checkForStrongName { channel } {
tputs $channel "---- checking for strong name... "
if {[catch {object invoke Interpreter.GetActive GetStrongName} \
strongName] == 0 && \
[string length $strongName] > 0} then {
#
# NOTE: Yes, it appears that the core library was signed with a
# strong name key.
#
addConstraint strongName
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForCertificate { channel } {
tputs $channel "---- checking for certificate... "
if {[catch {object invoke Interpreter.GetActive GetCertificate} \
certificate] == 0 && \
[string length $certificate] > 0} then {
#
# NOTE: Yes, it appears that the core library was signed with a
# code-signing certificate.
#
addConstraint certificate
tputs $channel [appendArgs "yes (" \
[object invoke $certificate Subject] ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForCompileCSharp { channel } {
tputs $channel "---- checking for test use of C# compiler... "
if {![info exists ::no(compileCSharp)]} then {
addConstraint compileCSharp
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForAdministrator { channel } {
tputs $channel "---- checking for administrator... "
if {[isAdministrator]} then {
addConstraint administrator; # running as full admin.
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForHost { channel } {
tputs $channel "---- checking for host... "
if {[catch {host isopen} open] == 0} then {
if {$open} then {
addConstraint hostIsOpen
tputs $channel open\n
} else {
if {[catch {host redirected Input} redirected] == 0} then {
if {$redirected} then {
addConstraint hostInputRedirected
tputs $channel redirected\n
} else {
addConstraint hostIsClosed
tputs $channel closed\n
}
} else {
tlog $redirected; tputs $channel error\n
}
}
} else {
tlog $open; tputs $channel error\n
}
}
proc checkForHostType { channel } {
tputs $channel "---- checking for host type... "
if {[set code [catch {object invoke \
Interpreter.GetActive.Host.GetType ToString} hostType]] == 0 && \
[string length $hostType] > 0} then {
addConstraint [appendArgs hostType. [string map \
[list , _ + _ & _ * _ \[ _ \] _ . _ \\ _] $hostType]]
tputs $channel [appendArgs $hostType \n]
} elseif {$code == 0} then {
tputs $channel unknown\n
} else {
tputs $channel error\n
}
}
proc checkForPrimaryThread { channel } {
tputs $channel "---- checking for primary thread... "
if {[catch {object invoke Interpreter.GetActive ThreadId} \
threadId] == 0 && \
[info tid] == $threadId} then {
addConstraint primaryThread
tputs $channel [appendArgs "yes (" $threadId ")\n"]
} else {
tputs $channel [appendArgs "no (" $threadId ")\n"]
}
}
proc checkForDefaultAppDomain { channel } {
tputs $channel "---- checking for default application domain... "
if {[catch {object invoke AppDomain CurrentDomain} appDomain] == 0 && \
[string length $appDomain] > 0} then {
if {[object invoke $appDomain IsDefaultAppDomain]} then {
addConstraint defaultAppDomain
tputs $channel [appendArgs "yes (" [object invoke $appDomain Id] \
")\n"]
} else {
tputs $channel [appendArgs "no (" [object invoke $appDomain Id] \
")\n"]
}
} else {
tputs $channel [appendArgs "no (null)\n"]
}
}
proc checkForRuntime { channel } {
tputs $channel "---- checking for runtime... "
#
# NOTE: Are we running inside Mono (regardless of operating system)?
#
if {![info exists ::no(mono)] && [isMono]} then {
#
# NOTE: Yes, it appears that we are running inside Mono.
#
addConstraint mono; # running on Mono.
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : "Mono"}] \n]
} else {
#
# NOTE: No, it appears that we are not running inside Mono.
#
addConstraint dotNet; # running on .NET.
#
# NOTE: We do not want to skip Mono bugs on .NET.
#
addConstraint monoToDo; # running on .NET.
addConstraint monoBug; # running on .NET.
addConstraint monoCrash; # running on .NET.
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : "Microsoft.NET"}] \n]
}
}
proc checkForImageRuntimeVersion { channel } {
tputs $channel "---- checking for image runtime version... "
if {[info exists ::eagle_platform(imageRuntimeVersion)] && \
[string length $::eagle_platform(imageRuntimeVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the version only.
#
set dotVersion [join [lrange [split \
$::eagle_platform(imageRuntimeVersion) .] 0 1] .]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list v "" . ""] $dotVersion]
#
# NOTE: Keep track of the specific image runtime version for usage in
# test constraints.
#
addConstraint [appendArgs imageRuntime $version]
tputs $channel [appendArgs $::eagle_platform(imageRuntimeVersion) \
" " ( $dotVersion ) \n]
} else {
tputs $channel no\n
}
}
proc checkForFrameworkVersion { channel } {
tputs $channel "---- checking for framework version... "
if {[info exists ::eagle_platform(frameworkVersion)] && \
[string length $::eagle_platform(frameworkVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the version only.
#
set dotVersion [join [lrange [split \
$::eagle_platform(frameworkVersion) .] 0 1] .]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list . ""] $dotVersion]
#
# NOTE: If the framework version was found, add a test constraint
# for it now.
#
if {[string length $version] > 0} then {
addConstraint [appendArgs framework $version]
}
tputs $channel [appendArgs $::eagle_platform(frameworkVersion) \
" " ( $dotVersion ) \n]
} else {
tputs $channel no\n
}
}
proc checkForRuntimeVersion { channel } {
tputs $channel "---- checking for runtime version... "
if {[info exists ::eagle_platform(runtimeVersion)] && \
[string length $::eagle_platform(runtimeVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the version only.
#
set dotVersion [join [lrange [split \
$::eagle_platform(runtimeVersion) .] 0 1] .]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list . ""] $dotVersion]
if {![info exists ::no(mono)] && [isMono]} then {
#
# NOTE: If the runtime version was found, add a test constraint
# for it now.
#
if {[string length $version] > 0} then {
#
# NOTE: We are running on Mono. Keep track of the specific
# version for usage in test constraints.
#
addConstraint [appendArgs mono $version]
addConstraint [appendArgs mono $version OrHigher]
}
#
# NOTE: Attempt to parse the version into its major and minor
# components.
#
if {[string length $dotVersion] > 0 && [regexp -- {^(\d+)\.(\d+)$} \
$dotVersion dummy majorVersion minorVersion]} then {
#
# NOTE: This is the list of Mono versions to add test
# constraints for.
#
set monoVersions [list]
#
# NOTE: Check each Mono version "known" to the test suite.
#
foreach monoVersion [getKnownMonoVersions] {
#
# NOTE: Check for any Mono major version X or higher.
#
if {$majorVersion >= [lindex $monoVersion 0]} then {
#
# NOTE: Check for any Mono major/minor version higher
# than X.Y.
#
if {$majorVersion > [lindex $monoVersion 0] || \
$minorVersion > [lindex $monoVersion 1]} then {
#
# NOTE: Add this "known" version of Mono.
#
lappend monoVersions $monoVersion
}
}
}
#
# NOTE: Add the necessary constraints for each version of Mono
# we should NOT skip bugs for.
#
foreach monoVersion $monoVersions {
set constraintVersion [join $monoVersion ""]
addConstraint [appendArgs mono $constraintVersion OrHigher]
addConstraint [appendArgs monoToDo $constraintVersion]
addConstraint [appendArgs monoBug $constraintVersion]
addConstraint [appendArgs monoCrash $constraintVersion]
}
#
# NOTE: Check all known versions of Mono for an exact match with
# the currently running one.
#
foreach monoVersion [getKnownMonoVersions] {
#
# NOTE: Check if Mono major/minor version is exactly the one
# we are currently processing.
#
set constraintVersion [join $monoVersion ""]
if {[lindex $monoVersion 0] == $majorVersion && \
[lindex $monoVersion 1] == $minorVersion} then {
#
# NOTE: Add test constraints that only apply to this exact
# version of Mono.
#
addConstraint [appendArgs mono $constraintVersion Only]
} else {
#
# NOTE: Add test constraints that apply to all versions of
# Mono except this exact version.
#
addConstraint [appendArgs monoToDo $constraintVersion Only]
addConstraint [appendArgs monoBug $constraintVersion Only]
addConstraint [appendArgs monoCrash $constraintVersion Only]
}
}
}
} else {
#
# NOTE: If the runtime version was found, add a test constraint
# for it now.
#
if {[string length $version] > 0} then {
#
# NOTE: We are running on the .NET Framework. Keep track of the
# specific version for usage in test constraints.
#
addConstraint [appendArgs dotNet $version]
addConstraint [appendArgs dotNet $version OrHigher]
}
#
# NOTE: We do not want to skip any Mono bugs on .NET. Add the
# necessary constraints for each version of Mono we know
# about.
#
foreach monoVersion [getKnownMonoVersions] {
set constraintVersion [join $monoVersion ""]
addConstraint [appendArgs monoToDo $constraintVersion]
addConstraint [appendArgs monoToDo $constraintVersion Only]
addConstraint [appendArgs monoBug $constraintVersion]
addConstraint [appendArgs monoBug $constraintVersion Only]
addConstraint [appendArgs monoCrash $constraintVersion]
addConstraint [appendArgs monoCrash $constraintVersion Only]
}
}
tputs $channel [appendArgs $::eagle_platform(runtimeVersion) \
" " ( $dotVersion ) \n]
} else {
tputs $channel no\n
}
}
proc checkForProcessBits { channel } {
tputs $channel "---- checking for process bits... "
if {[info exists ::tcl_platform(processBits)] && \
[string is integer -strict $::tcl_platform(processBits)]} then {
addConstraint [appendArgs $::tcl_platform(processBits) bit]
tputs $channel [appendArgs $::tcl_platform(processBits) -bit\n]
} else {
tputs $channel unknown\n
}
}
proc checkForMachine { channel bits machine } {
tputs $channel [appendArgs "---- checking for machine \"" $bits \
"-bit " $machine "\"... "]
#
# NOTE: What are the machine architecture and the
# number of bits for this operating system?
#
if {[info exists ::tcl_platform(machine)] && \
[info exists ::tcl_platform(processBits)]} then {
#
# NOTE: Does the machine and number of bits match
# what the caller specified?
#
if {$::tcl_platform(machine) eq $machine && \
$::tcl_platform(processBits) eq $bits} then {
#
# NOTE: Yes, it matches.
#
addConstraint [appendArgs $machine . $bits bit]
set result yes
} else {
set result no
}
tputs $channel [appendArgs $result ", " $::tcl_platform(processBits) \
-bit " " $::tcl_platform(machine) \n]
} else {
tputs $channel "no, unknown\n"
}
}
proc checkForGarudaDll { channel } {
#
# NOTE: Skip automatic Tcl shell machine detection if we are not
# allowed to execute external commands.
#
if {[canExecTclShell]} then {
#
# NOTE: Have the [getGarudaDll] procedure automatically detect the
# machine.
#
set machine ""
} else {
#
# NOTE: Use the machine for this test run.
#
set machine [getTestMachine]
#
# NOTE: Since an empty string means "automatically detect" to the
# [getGarudaDll] procedure, we must make sure the value is
# something else.
#
if {[string length $machine] == 0} then {
set machine unknown
}
}
#
# NOTE: Check for the Garuda DLL of the same platform (i.e. machine
# type) as the native Tcl shell.
#
return [checkForFile $channel [getGarudaDll $machine]]
}
proc checkForCulture { channel } {
tputs $channel "---- checking for culture... "
#
# NOTE: Grab the current culture.
#
set culture [info culture]
if {[string length $culture] > 0} then {
#
# NOTE: The culture information is present, use it and show it.
#
addConstraint [appendArgs culture. [string map [list - _] $culture]]
tputs $channel [appendArgs $culture \n]
} else {
tputs $channel unknown\n
}
}
proc checkForThreadCulture { channel } {
tputs $channel "---- checking for thread culture... "
#
# NOTE: Grab the current thread culture.
#
if {[catch {object invoke System.Threading.Thread.CurrentThread \
CurrentCulture} culture] == 0 && \
[catch {object invoke Eagle._Components.Private.FormatOps \
CultureName $culture false} culture] == 0 && \
[string length $culture] > 0} then {
#
# NOTE: The culture information is present, use it and show it.
#
addConstraint [appendArgs threadCulture. [string map [list - _] \
$culture]]
tputs $channel [appendArgs $culture \n]
} else {
tputs $channel unknown\n
}
}
proc checkForQuiet { channel quiet } {
if {!$quiet} then {
tputs $channel "---- checking for quiet... "
}
if {[catch {
object invoke Interpreter.GetActive Quiet
} isQuiet] == 0 && $isQuiet} then {
#
# NOTE: Yes, quiet mode is enabled.
#
addConstraint quiet
if {!$quiet} then {
tputs $channel yes\n
}
} else {
if {!$quiet} then {
tputs $channel no\n
}
}
}
proc checkForReferenceCountTracking { channel } {
tputs $channel "---- checking for object reference count tracking... "
if {[info exists ::eagle_platform(compileOptions)] && \
([lsearch -exact -nocase $::eagle_platform(compileOptions) \
NOTIFY] != -1 || \
[lsearch -exact -nocase $::eagle_platform(compileOptions) \
NOTIFY_OBJECT] != -1)} then {
#
# NOTE: Yes, support for object reference count tracking is present.
#
addConstraint refCount
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForRuntimeOption { channel option } {
tputs $channel [appendArgs "---- checking for runtime option \"" \
$option "\"... "]
if {[info exists ::eagle_platform(runtimeOptions)] && \
[lsearch -exact -nocase $::eagle_platform(runtimeOptions) \
$option] != -1} then {
#
# NOTE: Yes, support for the runtime option is present.
#
addConstraint [appendArgs runtime. $option]
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForDynamicLoading { channel } {
tputs $channel "---- checking for dynamic loading... "
#
# NOTE: As far as we know, dynamic loading always works on Windows.
# On some Unix systems, dlopen does not work (e.g. because
# Mono is statically linked, etc).
#
if {[isWindows] || ([llength [info commands library]] > 0 && \
[catch {library test}] == 0)} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint dynamic
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForWindowsForms { channel } {
tputs $channel "---- checking for Windows Forms... "
#
# HACK: When running on Windows, we do not need to do any other
# special checks here; however, on Unix (and Mac OS X?),
# we should check for the DISPLAY environment variable as
# some basic indication that the X server is available.
# This appears to be very necessary on Mono because it
# crashes after repeated failed attempts to create a
# Windows Form when the X server is unavailable (e.g. on
# OpenBSD).
#
if {[isWindows] || [info exists ::env(DISPLAY)]} then {
#
# NOTE: Is the Windows Forms assembly available?
#
if {[catch {object resolve System.Windows.Forms} assembly] == 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint winForms
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForWoW64 { channel } {
tputs $channel "---- checking for WoW64... "
if {[info exists ::eagle_platform(wow64)] && \
[string is boolean -strict $::eagle_platform(wow64)] && \
$::eagle_platform(wow64)} then {
#
# NOTE: Yes, we are running in a WoW64 process.
#
addConstraint wow64
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForStaThread { channel } {
tputs $channel "---- checking for STA thread... "
if {[catch {object invoke System.Threading.Thread.CurrentThread \
GetApartmentState} apartmentState] == 0 && \
$apartmentState eq "STA"} then {
#
# NOTE: Yes, we are running in an STA thread.
#
addConstraint staThread
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForWindowsPresentationFoundation { channel } {
tputs $channel "---- checking for Windows Presentation Foundation... "
#
# NOTE: Is the Windows Presentation Foundation available?
#
if {[catch {object resolve PresentationFramework} assembly] == 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint wpf
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForDatabase { channel type string } {
tputs $channel "---- checking for database... "
#
# HACK: Disable database connectivity testing on Mono because
# it fails to timeout (unless special test suite hacks
# for Mono have been disabled by the user).
#
if {[info exists ::no(mono)] || ![isMono]} then {
#
# NOTE: Can we access the local database?
#
if {[catch {sql open -type $type $string} connection] == 0} then {
#
# NOTE: Yes, it appears that we can connect to the local database.
#
addConstraint database
#
# NOTE: Also record the test database connection type used as a
# test constraint.
#
if {[string length $type] > 0} then {
addConstraint [appendArgs database. [string tolower $type]]
}
#
# NOTE: Cleanup the database connection we just opened.
#
sql close $connection
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
tputs $channel disabled\n
}
}
proc checkForAssembly { channel name } {
tputs $channel [appendArgs "---- checking for assembly \"" $name \
"\"... "]
#
# NOTE: Can the assembly be loaded?
#
if {[catch {object resolve $name} assembly] == 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint $name
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForObjectMember { channel object member {constraint ""} } {
tputs $channel [appendArgs "---- checking for object member \"" \
$object . $member "\"... "]
if {[catch {object members -flags +NonPublic -pattern $member $object} \
members] == 0 && \
[llength $members] > 0} then {
#
# NOTE: Yes, it appears that it is available.
#
if {[string length $constraint] > 0} then {
addConstraint [appendArgs member_ $constraint]
} else {
addConstraint [appendArgs $object. [string trim $member *?]]
}
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTclInstalls { channel } {
tputs $channel "---- checking for Tcl installs... "
#
# NOTE: Check for dynamically loadable Tcl libraries (for this
# architecture only).
#
if {[catch {tcl select -architecture} tcl] == 0} then {
#
# NOTE: Did we find one? Attempt to grab the index
# of the version field from the list.
#
set index [lsearch -exact $tcl version]
if {$index != -1} then {
#
# NOTE: The very next list index contains the value
# (i.e. like a Tcl 8.5+ dict).
#
set dotVersion [lindex $tcl [incr index]]
#
# NOTE: Do we know the version?
#
if {[string length $dotVersion] > 0 && \
[regexp -- {^\d+\.\d+$} $dotVersion]} then {
#
# NOTE: Yes, some version of Tcl is available.
#
addConstraint tclLibrary
#
# NOTE: Is the version 8.x or higher?
#
if {$dotVersion >= 8.6} then {
addConstraint tclLibrary86
} elseif {$dotVersion >= 8.5} then {
addConstraint tclLibrary85
} elseif {$dotVersion >= 8.4} then {
addConstraint tclLibrary84
}
tputs $channel [appendArgs $dotVersion \n]
#
# NOTE: We are done here, return now.
#
return
}
}
}
tputs $channel no\n
}
proc checkForTclReady { channel } {
tputs $channel "---- checking for Tcl readiness... "
if {[catch {tcl ready} ready] == 0 && $ready} then {
#
# NOTE: Yes, native Tcl is loaded and ready.
#
addConstraint tclReady
#
# NOTE: Yes, native Tcl is ready -OR- available.
#
addConstraint tclReadyOrLibrary
#
# NOTE: Ok, attempt to determine the loaded Tcl version.
#
if {[catch {
tcl eval [tcl master] {info tclversion}
} version] == 0 && [regexp -- {^\d+\.\d+$} $version]} then {
addConstraint [appendArgs \
tclReady [string map [list . ""] $version]]
#
# NOTE: The Tcl library is ready; however, we need to add the
# appropriate test constraint to indicate that a specific
# version of Tcl is "either ready or available".
#
if {[haveConstraint tclLibrary86] && $version >= 8.6} then {
addConstraint tclReadyOrLibrary86
} elseif {[haveConstraint tclLibrary85] && $version >= 8.5} then {
addConstraint tclReadyOrLibrary85
} elseif {[haveConstraint tclLibrary84] && $version >= 8.4} then {
addConstraint tclReadyOrLibrary84
}
tputs $channel [appendArgs "yes (" $version ")\n"]
} else {
#
# NOTE: The Tcl library is ready; however, we have no idea what
# version it actually is; therefore, skip adding the test
# constraint to indicate that a specific version of Tcl
# is "either ready or available".
#
tputs $channel yes\n
}
} else {
#
# NOTE: The Tcl library is not ready; however, we still need to add
# the appropriate test constraint to indicate that a specific
# version of Tcl is "either ready or available".
#
if {[haveConstraint tclLibrary86]} then {
addConstraint tclReadyOrLibrary86
} elseif {[haveConstraint tclLibrary85]} then {
addConstraint tclReadyOrLibrary85
} elseif {[haveConstraint tclLibrary84]} then {
addConstraint tclReadyOrLibrary84
}
tputs $channel no\n
}
}
proc checkForTclShell { channel } {
#
# HACK: If this returns "error" that normally indicates an error was
# caught during [exec] (i.e. the native Tcl shell could not be
# executed).
#
set prefix "---- checking for Tcl shell version... "
if {[canExecTclShell] && \
[catch {getTclVersionForTclShell} version] == 0 && \
$version ne "error"} then {
#
# NOTE: Yes, a native Tcl shell appears to be available.
#
addConstraint tclShell
#
# NOTE: Now, add the version specific test constraint.
#
addConstraint [appendArgs \
tclShell [string map [list . ""] $version]]
tputs $channel [appendArgs $prefix "yes (" $version ")\n"]
} else {
tputs $channel [appendArgs $prefix no\n]
}
}
proc checkForTkPackage { channel } {
#
# HACK: We do not care about the Tk version returned from this
# procedure, we only care if it returns "error" because that
# would indicate an error was caught during [exec] (i.e. the
# native Tcl shell could not be executed).
#
set prefix "---- checking for Tk package version... "
if {[canExecTclShell] && \
[catch {getTkVersionForTclShell} version] == 0 && \
$version ne "error"} then {
#
# NOTE: Yes, a native Tk package appears to be available.
#
addConstraint tkPackage
tputs $channel [appendArgs $prefix "yes (" $version ")\n"]
} else {
tputs $channel [appendArgs $prefix no\n]
}
}
proc checkForPowerShell { channel } {
tputs $channel "---- checking for PowerShell... "
#
# NOTE: Can the PowerShell assembly be loaded?
#
if {[catch {object resolve System.Management.Automation} \
assembly] == 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint powerShell
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForWix { channel } {
tputs $channel "---- checking for WiX... "
#
# NOTE: Platform must be Windows for this constraint to
# even be checked (i.e. we require the registry).
#
if {[isWindows]} then {
#
# NOTE: Indicate that we have not found it yet.
#
set directory ""
#
# NOTE: Have we not found the directory yet?
#
# Yes, this is somewhat redundant because we just set
# the directory to an empty string (above); however,
# maintaining a uniform pattern is more important.
#
if {[string length $directory] == 0} then {
#
# NOTE: Check for the WIX environment variable.
#
if {[info exists ::env(WIX)]} then {
set directory [file normalize [string trimright $::env(WIX)]]
if {[string length $directory] > 0} then {
#
# NOTE: We need the directory containing the binaries.
#
set directory [file join $directory bin]
#
# NOTE: Does the directory actually exist?
#
if {[file isdirectory $directory]} then {
#
# NOTE: The file name of the primary WiX assembly.
#
set fileName [file join $directory wix.dll]
#
# NOTE: We do not know the file version yet.
#
set version ""
#
# NOTE: Attempt to query the version of the file.
#
if {[catch {file version $fileName} version] == 0 && \
[string length $version] > 0} then {
#
# NOTE: Indicate where we found the file.
#
set where environment
} else {
#
# NOTE: The file does not exist or is not properly
# versioned.
#
set directory ""
}
} else {
#
# NOTE: The directory does not exist.
#
set directory ""
}
}
}
}
#
# NOTE: Have we not found the directory yet?
#
if {[string length $directory] == 0} then {
#
# NOTE: Registry hive where WiX install information is stored. Make
# sure to look in the WoW64 registry because WiX is currently
# always installed as a 32-bit application.
#
set key [appendArgs HKEY_LOCAL_MACHINE\\ \
[getSoftwareRegistryKey true] {\Microsoft\Windows Installer XML}]
#
# NOTE: The versions of WiX that we support.
#
set versions [list 3.7 3.6 3.5 3.0]
#
# NOTE: Check each version, stopping when one is found.
#
foreach version $versions {
#
# NOTE: Attempt to fetch the WiX install directory value from the
# registry, removing the trailing backslash, if any. Does
# the directory name look valid and does it actually exist?
#
if {[catch {file normalize [string trimright [object invoke \
Microsoft.Win32.Registry GetValue [appendArgs $key \\ \
$version] InstallRoot null] \\]} directory] == 0 && \
[string length $directory] > 0 && \
[file isdirectory $directory]} then {
#
# NOTE: The file name of the primary WiX assembly.
#
set fileName [file join $directory wix.dll]
#
# NOTE: We do not know the file version yet.
#
set version ""
#
# NOTE: Attempt to query the version of the file.
#
if {[catch {file version $fileName} version] == 0 && \
[string length $version] > 0} then {
#
# NOTE: Indicate where we found the file.
#
set where registry
#
# NOTE: We found it, bail out now.
#
break
} else {
#
# NOTE: The file does not exist or is not properly
# versioned.
#
set directory ""
}
}
}
}
#
# NOTE: Did we find the directory?
#
if {[string length $directory] > 0 && \
[file isdirectory $directory]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint wix
#
# NOTE: Save the directory for later usage by
# the test itself.
#
if {![info exists ::no(setWix)]} then {
set ::test_wix $directory
}
#
# NOTE: Show where we found it.
#
tputs $channel [appendArgs "yes (" $version ", via " $where ", \"" \
$directory "\")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForTargetFramework { channel } {
tputs $channel "---- checking for target framework... "
if {[info exists ::eagle_platform(targetFramework)] && \
[string length $::eagle_platform(targetFramework)] > 0} then {
#
# NOTE: Now create a string for use in the constraint name (remove
# the invalid characters). For example:
#
# ".NETFramework,Version=v2.0" --> "NETFramework.Version.v2.0"
#
set targetFramework [string trimleft [string map [list , . = .] \
$::eagle_platform(targetFramework)] .]
#
# NOTE: Keep track of the specific target framework for usage in test
# constraints.
#
addConstraint [appendArgs targetFramework. $targetFramework]
tputs $channel [appendArgs $::eagle_platform(targetFramework) \
" " ( $targetFramework ) \n]
} else {
tputs $channel no\n
}
}
proc checkForNativeUtility { channel } {
tputs $channel "---- checking for native utility... "
if {[info exists ::eagle_platform(nativeUtility)] && \
[string length $::eagle_platform(nativeUtility)] > 0} then {
set name [lindex $::eagle_platform(nativeUtility) 0]
if {[string length $name] > 0} then {
set version [lindex $::eagle_platform(nativeUtility) 1]
if {[string length $version] > 0} then {
set nativeUtility [appendArgs \
$name . [join [lrange [split $version .] 0 1] .]]
} else {
set nativeUtility $name
}
if {$nativeUtility ni "disabled unavailable"} then {
addConstraint nativeUtility
}
addConstraint [appendArgs nativeUtility. $nativeUtility]
tputs $channel [appendArgs $::eagle_platform(nativeUtility) \
" " ( $nativeUtility ) \n]
} else {
tputs $channel unknown\n
}
} else {
tputs $channel no\n
}
}
proc checkForNetFx45 { channel } {
tputs $channel "---- checking for .NET Framework 4.5... "
#
# NOTE: Platform must be Windows for this constraint to even be
# checked (i.e. we require the registry).
#
if {[isWindows]} then {
#
# NOTE: Registry hive where the .NET Framework 4.0 setup and
# servicing information is stored. No need to look in
# the WoW64 registry because the .NET Framework should
# be installed natively as well.
#
set key [appendArgs HKEY_LOCAL_MACHINE\\ \
{Software\Microsoft\NET Framework Setup\NDP\v4\Full}]
#
# NOTE: Attempt to fetch the .NET Framework 4.0 "release" value from
# the servicing registry hive. If this value does not exist
# -OR- is less than 378389, then the .NET Framework 4.5 is not
# installed.
#
set release [object invoke Microsoft.Win32.Registry GetValue $key \
Release null]
if {[string is integer -strict $release] && $release >= 378389} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint dotNet45OrHigher
#
# NOTE: If the "release" value is greater than or equal to 378758,
# then the .NET Framework 4.5.1 is installed.
#
if {$release >= 378758} then {
addConstraint dotNet451
addConstraint dotNet451OrHigher
set version 4.5.1
} else {
addConstraint dotNet45
set version 4.5
}
#
# NOTE: Show the "release" value we found in the registry.
#
tputs $channel [appendArgs "yes (" $release ", " $version ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForVisualStudio { channel } {
tputs $channel "---- checking for Visual Studio... "
#
# NOTE: Platform must be Windows for this constraint to even be
# checked (i.e. we require the registry).
#
set visualStudioVersions [list]
if {[isWindows]} then {
#
# NOTE: Registry hive where Visual Studio install information is
# stored. Make sure to look in the WoW64 registry because
# Visual Studio is currently always a 32-bit application.
#
set key [appendArgs HKEY_LOCAL_MACHINE\\ \
[getSoftwareRegistryKey true] {\Microsoft\VisualStudio}]
#
# NOTE: The versions of Visual Studio that we support.
#
set versions [list [list 8.0 2005] [list 9.0 2008] \
[list 10.0 2010] [list 11.0 2012] [list 12.0 2013]]
#
# NOTE: Check each version and keep track of the ones we find.
#
foreach version $versions {
#
# NOTE: Attempt to fetch the Visual Studio install directory
# value from the registry, removing the trailing backslash,
# if any. Does the directory name look valid and does it
# actually exist?
#
if {[catch {file normalize [file join [string trimright [object \
invoke Microsoft.Win32.Registry GetValue [appendArgs $key \\ \
[lindex $version 0]] InstallDir null] \\] msenv.dll]} \
fileName] == 0 && \
[string length $fileName] > 0 && [file isfile $fileName]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs visualStudio [lindex $version 1]]
#
# NOTE: Keep track of all the versions that we find.
#
lappend visualStudioVersions [lindex $version 1]
#
# NOTE: Save the directory for later usage by
# the test itself.
#
if {![info exists ::no(setVisualStudio)]} then {
set ::test_visual_studio [file dirname $fileName]
}
}
}
}
if {[llength $visualStudioVersions] > 0} then {
#
# NOTE: Show where we found the latest version.
#
tputs $channel [appendArgs "yes (" $visualStudioVersions ", \"" \
$::test_visual_studio "\")\n"]
} else {
tputs $channel no\n
}
}
proc checkForNativeDebugger { channel } {
tputs $channel "---- checking for native debugger... "
#
# NOTE: Is the native debugger present?
#
if {[catch {object invoke -flags +NonPublic \
Eagle._Components.Private.NativeOps+SafeNativeMethods \
IsDebuggerPresent} present] == 0 && $present} then {
#
# NOTE: Yes, it appears that it is present.
#
addConstraint nativeDebugger
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForManagedDebugger { channel } {
tputs $channel "---- checking for managed debugger... "
#
# NOTE: Is the managed debugger attached?
#
if {[catch {object invoke System.Diagnostics.Debugger IsAttached} \
attached] == 0 && $attached} then {
#
# NOTE: Yes, it appears that it is attached.
#
addConstraint managedDebugger
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForScriptDebugger { channel } {
tputs $channel "---- checking for script debugger... "
#
# NOTE: Is the script debugger available?
#
if {[catch {object invoke -flags +NonPublic Interpreter.GetActive \
Debugger} debugger] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $debugger] > 0} then {
object flags $debugger +NoDispose
}
if {[regexp -- {^Debugger#\d+$} $debugger]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint scriptDebugger
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForScriptDebuggerInterpreter { channel } {
tputs $channel "---- checking for script debugger interpreter... "
#
# NOTE: Is the script debugger interpreter available?
#
if {[catch {object invoke -flags +NonPublic Interpreter.GetActive \
Debugger} debugger] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $debugger] > 0} then {
object flags $debugger +NoDispose
}
if {[regexp -- {^Debugger#\d+$} $debugger] && \
[catch {object invoke $debugger Interpreter} interp] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $interp] > 0} then {
object flags $interp +NoDispose
}
if {[regexp -- {^Interpreter#\d+$} $interp]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint scriptDebuggerInterpreter
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
}
tputs $channel no\n
}
###########################################################################
############################# END Eagle ONLY ##############################
###########################################################################
} else {
###########################################################################
############################# BEGIN Tcl ONLY ##############################
###########################################################################
#
# NOTE: We need several of our test constraint related commands in the
# global namespace.
#
exportAndImportPackageCommands [namespace current] [list \
getKnownCompileOptions getKnownMonoVersions lpermute \
alwaysFullInterpReady canExecTclShell canExecFossil \
checkForTestSuiteFiles checkForPlatform checkForWindowsVersion \
checkForScriptLibrary checkForVariable checkForTclOptions \
checkForWindowsCommandProcessor checkForFossil checkForEagle \
checkForSymbols checkForLogFile checkForGaruda checkForShell \
checkForDebug checkForTk checkForVersion checkForCommand \
checkForNamespaces checkForTestExec checkForTestMachine \
checkForTestPlatform checkForTestConfiguration checkForTestSuffix \
checkForFile checkForPathFile checkForNativeCode checkForTip127 \
checkForTip194 checkForTip207 checkForTip241 checkForTip285 \
checkForTip405 checkForTip426 checkForTip429 checkForTiming \
checkForPerformance checkForBigLists checkForMemoryIntensive \
checkForStackIntensive checkForInteractive checkForInteractiveCommand \
checkForUserInteraction checkForNetwork checkForCompileOption \
checkForKnownCompileOptions] false false
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: Provide the Eagle test constraints package to the interpreter.
#
package provide Eagle.Test.Constraints \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}