###############################################################################
#
# constraints.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Test Constraints 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 getKnownBuildTypes {} {
return [list \
NetFx20 NetFx35 NetFx40 NetFx45 NetFx451 \
NetFx452 NetFx46 NetFx461 NetFx462 NetFx47 \
NetFx471 NetFx472 NetStandard20 Bare LeanAndMean \
Database MonoOnUnix Development]
}
proc getKnownCompileOptions {} {
return [list \
APPDOMAINS APPROVED_VERBS ARGUMENT_CACHE ARM ARM64 ASSEMBLY_DATETIME \
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 \
CERTIFICATE_PLUGIN CERTIFICATE_POLICY CERTIFICATE_RENEWAL \
CODE_ANALYSIS COM_TYPE_CACHE CONFIGURATION CONSOLE DAEMON DATA \
DEAD_CODE DEBUG DEBUGGER DEBUGGER_ARGUMENTS DEBUGGER_ENGINE \
DEBUGGER_EXECUTE DEBUGGER_EXPRESSION DEBUGGER_VARIABLE DEBUG_TRACE \
DEBUG_WRITE DEMO_EDITION DRAWING DYNAMIC EAGLE EMBEDDED_LIBRARY \
EMBED_CERTIFICATES EMIT ENTERPRISE_LOCKDOWN EXECUTE_CACHE \
EXPRESSION_FLAGS FAST_ERRORCODE FAST_ERRORINFO FOR_TEST_USE_ONLY \
FORCE_TRACE HAVE_SIZEOF HISTORY IA64 INTERACTIVE_COMMANDS \
INTERNALS_VISIBLE_TO ISOLATED_INTERPRETERS ISOLATED_PLUGINS LIBRARY \
LICENSING LICENSE_MANAGER LIMITED_EDITION LIST_CACHE MONO MONO_BUILD \
MONO_HACKS MONO_LEGACY NATIVE NATIVE_PACKAGE NATIVE_THREAD_ID \
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 NET_46 NET_461 NET_462 NET_47 NET_471 NET_472 NET_CORE_20 \
NET_STANDARD_20 NON_WORKING_CODE NOTIFY NOTIFY_ACTIVE \
NOTIFY_ARGUMENTS NOTIFY_EXCEPTION NOTIFY_EXECUTE NOTIFY_EXPRESSION \
NOTIFY_GLOBAL NOTIFY_OBJECT OBSOLETE OBFUSCATION OFFICIAL PARSE_CACHE \
PATCHLEVEL PLUGIN_COMMANDS POLICY_TRACE PREVIOUS_RESULT RANDOMIZE_ID \
REMOTING RESULT_LIMITS SAMPLE SECURITY SERIALIZATION SHARED_ID_POOL \
SHELL SOURCE_ID SOURCE_TIMESTAMP STATIC TCL TCL_KITS TCL_THREADED \
TCL_THREADS TCL_UNICODE TCL_WRAPPER TEST TEST_PLUGIN THREADING \
THROW_ON_DISPOSED TRACE TYPE_CACHE UNIX USE_APPDOMAIN_FOR_ID \
USE_NAMESPACES VERBOSE WEB WINDOWS WINFORMS WIX_30 WIX_35 WIX_36 \
WIX_37 WIX_38 WIX_39 WIX_310 WIX_311 X64 X86 XML]
}
proc getKnownMonoVersions { {force false} } {
#
# NOTE: This job of this procedure is to return the list of "known"
# versions of Mono supported by the test suite infrastructure.
#
# NOTE: Other than version 2.11 (which was officially announced and
# released), all of these releases are listed on the official
# release history pages:
#
# https://en.wikipedia.org/wiki/Mono_%28software%29
# https://www.mono-project.com/docs/about-mono/releases/
#
# TODO: This list should be manually updated when a new version of
# the Mono runtime is released.
#
if {$force || ![info exists ::no(monoVersions)]} then {
return [list \
[list 2 0] [list 2 2] [list 2 4] [list 2 6] [list 2 8] [list 2 10] \
[list 2 11] [list 3 0] [list 3 1] [list 3 2] [list 3 4] [list 3 6] \
[list 3 8] [list 3 10] [list 3 12] [list 4 0] [list 4 2] [list 4 4] \
[list 4 6] [list 4 8] [list 5 0] [list 5 2] [list 5 4] [list 5 8] \
[list 5 10] [list 5 12] [list 5 14] [list 5 16]]
} else {
return [list]
}
}
proc addKnownMonoConstraints { generic } {
#
# NOTE: Does the caller want to add the version-specific constraints
# or the generic ones?
#
if {!$generic} 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]
}
} else {
#
# 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 getKnownTclVersions { {force false} } {
#
# NOTE: This job of this procedure is to return the list of "known"
# versions of Tcl/Tk supported by the test suite infrastructure.
#
if {$force || ![info exists ::no(tclVersions)]} then {
return [list [list 8 4] [list 8 5] [list 8 6] [list 8 7]]
} else {
return [list]
}
}
proc filterKnownVersions {
versions {minimumVersion ""} {maximumVersion ""} } {
if {[string length $minimumVersion] > 0} then {
set dotMinimumVersion [getDottedVersion $minimumVersion]
} else {
set dotMinimumVersion ""
}
if {[string length $maximumVersion] > 0} then {
set dotMaximumVersion [getDottedVersion $maximumVersion]
} else {
set dotMaximumVersion ""
}
set result [list]
foreach version $versions {
set dotVersion [getDottedVersion $version]
if {[string length $dotMinimumVersion] > 0 && \
$dotVersion < $dotMinimumVersion} then {
continue
}
if {[string length $dotMaximumVersion] > 0 && \
$dotVersion > $dotMaximumVersion} then {
continue
}
lappend result $version
}
return $result
}
proc getDotNetCoreDirectoryNameOnly { path } {
#
# HACK: Obtain parent directory name that matches "net*", if any (e.g.
# "netcoreapp2.0", "netstandard2.0", etc).
#
if {[string length $path] > 0} then {
set tail [file tail $path]
if {[string match net* $tail]} then {
return $tail
}
}
return ""
}
proc getDotNetCoreLibPathDirectoryNameOnly { {name ""} } {
#
# NOTE: Search for matching directories based on the globally detected
# library path associated with the current core library.
#
if {[info exists ::core_lib_path] && \
[string length $::core_lib_path] > 0} then {
#
# NOTE: Make sure the directory actually exists before trying to find
# things within it.
#
if {[file isdirectory $::core_lib_path]} then {
#
# NOTE: Grab all directories that are directly beneath the detected
# library path, if any.
#
foreach directory [glob \
-nocomplain -types {d} -- [file join $::core_lib_path *]] {
#
# NOTE: If the caller specified a (plugin) name to match against,
# make sure it matches; otherwise, skip this directory.
#
if {[string length $name] > 0 && \
![string match $name [file tail $directory]]} then {
continue
}
#
# NOTE: Find directories beneath the current candidate directory
# that are .NET Core output directories.
#
set directories [glob \
-nocomplain -types {d} -- [file join $directory net*]]
#
# NOTE: If there is at least one match, we are done. Return the
# final path segment of the directory name to the caller.
#
if {[llength $directories] > 0} then {
return [file tail [lindex $directories 0]]
}
}
}
}
#
# NOTE: There was no match, just return something obviously invalid.
#
return ""
}
proc getDottedVersion { version } {
return [join $version .]
}
proc getDotlessVersion { version } {
if {[string first . $version] != -1} then {
return [string map [list . ""] $version]
} else {
return [join $version ""]
}
}
proc getMajorMinorVersion { version } {
return [join [lrange [split $version .] 0 1] .]
}
#
# NOTE: This procedure was adapted from the one listed on the Tcl Wiki page
# at "https://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] || $readylimit == 0
}]
}
#
# NOTE: This procedure should return non-zero if the operating system
# 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 its execution.
#
proc canExecComSpec {} {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(comSpec)]} then {
return false
}
if {[info exists ::no(canExecComSpec)]} then {
return false
}
return true
}
#
# NOTE: This procedure should return non-zero if the "whoami" command 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 its execution.
#
proc canExecWhoAmI {} {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(whoami)]} then {
return false
}
if {[info exists ::no(canExecWhoAmI)]} then {
return false
}
return true
}
#
# 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 its execution.
#
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 its execution.
#
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
}
#
# NOTE: This procedure should return non-zero if the "vswhere" tool 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 its execution.
#
proc canExecVsWhere {} {
if {[info exists ::no(exec)]} then {
return false
}
if {[info exists ::no(vswhere)]} then {
return false
}
if {[info exists ::no(canExecVsWhere)]} then {
return false
}
return true
}
#
# NOTE: This procedure should return non-zero if the test suite should be
# considered to be running on Mono.
#
proc isTestMono {} {
return [expr {![info exists ::no(mono)] && [isMono]}]
}
#
# NOTE: This procedure should return non-zero if the test suite should be
# considered to be running on .NET Core.
#
proc isTestDotNetCore {} {
return [expr {![info exists ::no(dotNetCore)] && [isDotNetCore]}]
}
proc isTestAdministrator { {force false} } {
#
# NOTE: This is a workaround for the [isAdministrator] procedure being
# inaccurate for Mono on Windows, primarily due to the inability
# of Mono to call a P/Invoke method by ordinal. Also, this can
# be used for native Tcl on Windows. This only works on Windows.
#
if {[isWindows]} then {
#
# NOTE: Normally, this is only used for native Tcl or Eagle on Mono;
# however, it can be used for Eagle on the .NET Framework if
# forced.
#
if {$force || ![isEagle] || [isTestMono]} then {
if {[canExecWhoAmI] && \
[catch {exec -- whoami /groups} groups] == 0} then {
set groups [string map [list \r\n \n] $groups]
foreach group [split $groups \n] {
#
# NOTE: Match this group line against the "well-known" SID for
# the "Administrators" group on Windows.
#
if {[regexp -- {\sS-1-5-32-544\s} $group]} then {
#
# NOTE: Match this group line against the attributes column
# sub-value that should be present when running with
# elevated administrator credentials.
#
if {[regexp -- {\sEnabled group(?:,|\s)} $group]} then {
return true
}
}
}
}
}
}
#
# NOTE: We must be running in native Tcl, running on Unix, running in
# Eagle on the .NET Framework, or unable to execute the "whoami"
# command. If running in Eagle, we can just fallback to using
# the [isAdministrator] procedure; otherwise, just return false.
#
return [expr {[isEagle] ? [isAdministrator] : false}]
}
proc canPing { {varName ""} } {
#
# NOTE: If requested by the caller, provide a reason whenever false is
# returned from this procedure.
#
if {[string length $varName] > 0} then {
upvar 1 $varName reason
}
#
# NOTE: Native Tcl (without extra packages) does not provide support for
# pinging a network host.
#
if {[isEagle]} then {
if {[isTestMono]} then {
#
# NOTE: Using [uri ping] on the Mono 3.3.0 (or 3.4.0?) release will
# lock up the process; therefore, skip it in that case.
#
if {[haveConstraint mono33] || [haveConstraint mono34]} then {
set reason "skipped, may hang on Mono 3.3.0 and 3.4.0"
return false
}
#
# NOTE: Other versions of Mono, e.g. 3.12, appear to require elevated
# privileges (i.e. full administrator) in order to successfully
# execute [uri ping]. This has been verified on Windows.
#
if {![isTestAdministrator]} then {
set reason "skipped, need administrator privileges"
return false
}
}
#
# NOTE: Eagle, when running on the Microsoft .NET Framework, supports
# pinging a network host as long as it was compiled with network
# support (which this procedure purposely does not check). That
# is done using [checkForCompileOption], by the test prologue.
#
return true
}
set reason "skipped, need Eagle"
return false
}
proc cleanConstraintName { name } {
#
# NOTE: Start with the original constraint name, removing surrounding
# whitespace. If this results in an empty string, we are done.
#
set result [string trim $name]
if {[string length $result] == 0} then {
return $result
}
#
# NOTE: The constraints for a test are actually a list; therefore, we
# must remove anything that might confuse the list parser.
#
set result [string map [list \" "" \\ "" \{ "" \} ""] $result]
#
# NOTE: In order to avoid semantic confusion, remove other characters
# that may be reserved by the test suite subsystems.
#
set result [string map [list ! "" # "" \$ "" \; "" \[ "" \] ""] $result]
#
# NOTE: Finally, remove all remaining whitespace.
#
regsub -all -- {\s} $result "" result; return $result
}
proc cleanPackageName { package full } {
#
# NOTE: Start out with the original package name, removing surrounding
# whitespace. If this results in an empty string, we are done.
#
set result [string trim $package]
if {[string length $result] == 0} then {
return $result
}
#
# NOTE: If the full package name is NOT wanted, use the short name. It
# will be whatever occurs before the first comma. If this results
# in an empty string, we are done.
#
if {!$full} then {
set result [string trim [lindex [split $result ,] 0]]
if {[string length $result] == 0} then {
return $result
}
}
#
# HACK: This is the list of "special" characters that are documented to
# be used when constructing fully qualified .NET Framework type
# names. For now, they are all replaced with underscores by this
# procedure. Any existing underscores in the string are doubled.
#
set charMap [list _ __ " " _ + _ , _ . _ = _ \[ _ \\ _ \] _ ` _]
return [string map $charMap $result]
}
proc haveTclPlatformOsExtraUpdateName { name } {
if {[info exists ::tcl_platform(osExtra)]} then {
set updateNames [getDictionaryValue $::tcl_platform(osExtra) \
UpdateNames]
if {[lsearch -exact $updateNames $name] != -1} then {
return true
}
}
return false
}
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 \
auxiliary.eagle compat.eagle csharp.eagle database.eagle \
embed.eagle exec.eagle file1.eagle file2.eagle \
file3.eagle info.eagle init.eagle list.eagle \
object.eagle pkgIndex.eagle pkgIndex.tcl pkgt.eagle \
platform.eagle process.eagle runopt.eagle safe.eagle \
shell.eagle shim.eagle test.eagle testlog.eagle \
unkobj.eagle unzip.eagle update.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
}
}
#
# 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: 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 Test1.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
# suite path, add them here as well.
#
foreach fileNameOnly [list all.eagle epilogue.eagle 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:
#
# https://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 {
addKnownMonoConstraints true; # running in native Tcl.
addKnownMonoConstraints false; # running in native Tcl.
}
}
}
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: Grab the reported Windows version.
#
set osVersion $::tcl_platform(osVersion)
#
# NOTE: Double check that we are not being lied to by Windows
# about its real version number.
#
set extra ""
if {[canExecComSpec] && [info exists ::env(ComSpec)]} then {
#
# NOTE: Take advantage of the Windows command processor to
# run its internal VER command, which appears to always
# report the real Windows version number.
#
if {[catch {
exec $::env(ComSpec) /C VER
} comSpecVersion] == 0 && \
[regexp -- {Version (\d+\.\d+)} $comSpecVersion \
dummy comSpecVersion]} then {
#
# NOTE: If the value reported to the process does not match
# the value returned from the Windows command processor,
# replace it. We must know the real Windows version.
#
if {$osVersion eq $comSpecVersion} then {
set extra "---- reported and detected Windows versions match\n"
} else {
set extra [appendArgs \
"==== WARNING: reported and detected Windows versions " \
"do not match: " $osVersion " versus " $comSpecVersion \
", resetting...\n"]
set osVersion $comSpecVersion
}
}
}
#
# NOTE: Start out with the OS name, removing all spaces and then
# append the reported (or detected) OS version number.
#
set version [appendArgs \
[string map [list " " ""] $::tcl_platform(os)] _ \
$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" $osVersion ")\n"]
#
# NOTE: Log any extra message now.
#
if {[string length $extra] > 0} then {
tputs $channel $extra
}
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForOperatingSystemUpdate { channel name } {
tputs $channel [appendArgs \
"---- checking for operating system update \"" \
$name "\"... "]
#
# NOTE: Is the specific OS update currently installed?
#
if {[haveTclPlatformOsExtraUpdateName $name]} then {
addConstraint [appendArgs osUpdate . [cleanConstraintName $name]]
tputs $channel yes\n
} else {
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: These test constraints are needed by tests "socket-*.*".
#
if {![info exists ::no(compileNetwork)]} then {
lappend result compile.NETWORK
addConstraint compile.NETWORK
}
if {![info exists ::no(compileConfiguration)]} then {
lappend result compile.CONFIGURATION
addConstraint compile.CONFIGURATION
}
#
# 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 checkForPackage { channel pattern } {
tputs $channel [appendArgs \
"---- checking for loaded package matching \"" \
$pattern "\"... "]
if {[catch {
foreach loaded [info loaded] {
if {[regexp -- $pattern [lindex $loaded end]]} then {
set package [lindex $loaded 1]; break
}
}
}] == 0} then {
#
# NOTE: Make sure that a matching package name was found.
#
if {[info exists package]} then {
#
# NOTE: Yes, it appears that it is loaded.
#
addConstraint [appendArgs \
loaded.name. [cleanPackageName $package false]]
addConstraint [appendArgs \
loaded.fullName. [cleanPackageName $package true]]
#
# NOTE: Show that the sub-command was found.
#
tputs $channel yes\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-url} remoteUrl] == 0} then {
set remoteUrl [string trim $remoteUrl]; set validUrl false
if {[isEagle]} then {
#
# NOTE: With Eagle, we can actually validate the URL.
#
if {[uri isvalid $remoteUrl]} then {
set validUrl true
}
} else {
#
# HACK: Currently, there is no simple way to validate
# an arbitrary URL with Tcl (i.e. without using
# some hideously complex regular expression).
#
if {[string length $remoteUrl] > 0} then {
set validUrl true
}
}
if {$validUrl} then {
#
# NOTE: Add a constraint to show that a valid Fossil
# repository URL appears to be available.
#
addConstraint fossil_repository_url
#
# NOTE: If we are not prevented from doing so, save
# the test repository URL to the repository
# currently in use to a suitably named global
# variable.
#
if {![info exists ::no(setRepositoryUrl)]} then {
set ::test_repository_url $remoteUrl
}
#
# NOTE: Append the repository URL currently in use.
#
append result ", remote URL \"" $remoteUrl \"
}
}
if {[canExecFossil] && \
[catch {exec -- fossil info} info] == 0} then {
set info [string trim $info]; set validFile false
if {[string length $info] > 0} then {
set pattern {^repository:\s+(.*?)$}
if {[regexp -line -- $pattern $info dummy repository]} then {
set repository [string trim $repository]
if {[file exists $repository]} then {
set validFile true
}
}
}
if {$validFile} then {
#
# NOTE: Add a constraint to show that a valid Fossil
# repository file appears to be available.
#
addConstraint fossil_repository_file
#
# NOTE: Make sure the file name is fully normalized.
#
set repository [file normalize $repository]
#
# NOTE: If we are not prevented from doing so, save
# the test repository file for the repository
# currently in use to a suitably named global
# variable.
#
if {![info exists ::no(setRepositoryFile)]} then {
set ::test_repository_file $repository
}
#
# NOTE: Append the repository file currently in use.
#
append result ", local file \"" $repository \"
}
}
#
# 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 checkForVisualStudioViaVsWhere { channel } {
tputs $channel "---- checking for Visual Studio using \"vswhere\"... "
#
# NOTE: Initially, no versions of Visual Studio have been found.
#
set visualStudioVersions [list]
#
# NOTE: Use of the "vswhere" tool must be enabled for us to detect
# any instances of Visual Studio.
#
if {[canExecVsWhere]} then {
#
# NOTE: The versions of Visual Studio that we support detection
# of using the "vswhere" tool.
#
set versions [list [list 15.0 2017]]
#
# NOTE: Check each version and keep track of the ones we find.
#
foreach version $versions {
#
# NOTE: Attempt to fetch Visual Studio install directories
# value using the "vswhere" tool.
#
if {[canExecVsWhere] && [catch {
exec -nocarriagereturns -- vswhere -products * \
-version [lindex $version 0] -property installationPath
} installationPaths] == 0} then {
#
# NOTE: Check each Visual Studio install directory, in the
# order they were returned, after splitting them into
# a proper Tcl list.
#
set installationPaths [split \
[string trim $installationPaths] \n]
foreach installationPath $installationPaths {
#
# NOTE: Remove the trailing backslash, if any. Does the
# directory name look valid and does it actually
# exist?
#
set fileName [file join \
[string trimright $installationPath \\] Common7 IDE \
msenv.dll]
if {[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
# suite itself.
#
if {![info exists ::no(setVisualStudio)]} then {
set ::test_visual_studio [file dirname $fileName]
}
#
# HACK: Stop after we find the first instance of Visual
# Studio with the requested version.
#
break
}
}
}
}
}
if {[llength $visualStudioVersions] > 0} then {
#
# NOTE: Show where we found the latest version.
#
tputs $channel [appendArgs \
"yes (" $visualStudioVersions ", \"" \
[expr {[info exists ::test_visual_studio] ? \
$::test_visual_studio : "<none>"}] "\")\n"]
} else {
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 tclVersion [getKnownTclVersions] {
set version [getDotlessVersion $tclVersion]
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 tclVersion [getKnownTclVersions] {
set dotVersion [getDottedVersion $tclVersion]
if {$::tcl_version ne $dotVersion} then {
set version [getDotlessVersion $tclVersion]
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 {
#
# NOTE: By default, use strict matching of the shell executable
# name (exact); otherwise, match any executable names that
# start with "Eagle".
#
if {![info exists ::no(strictCheckForShell)]} then {
set match [expr {$name eq "Eagle" || $name eq "EagleShell"}]
} else {
set match [string match Eagle* $name]
}
#
# NOTE: Does the name of the executable file appear to be a match
# for one of the "well-known" shells?
#
if {$match} then {
#
# NOTE: We are running in Eagle via the EagleShell.
#
addConstraint shell
addConstraint [appendArgs shell. $name]
addConstraint dotNetCoreOrShell
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
addConstraint [appendArgs shell. $name]
addConstraint dotNetCoreOrShell
tputs $channel "yes (Tcl)\n"
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForOfficialStableReleaseInProgress { channel } {
#
# NOTE: If the tests appear to be running as part of the official stable
# release process for Eagle, then add the test constraint that will
# be checked by the [fixTimingConstraints] procedure, so that tests
# using it will not be counted against the overall results of the
# test run.
#
tputs $channel "---- checking for official stable release in progress... "
if {[info exists ::env(OFFICIAL)] && [info exists ::env(STABLE)]} then {
addConstraint officialStableReleaseInProgress
tputs $channel yes\n
} else {
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] || \
[haveConstraint tclLibrary87]} 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 {
#
# NOTE: First, obtain the list of all "known" Tcl versions.
#
set tclVersions [getKnownTclVersions]
#
# NOTE: *EAGLE* We do want to include any tests that target
# "Tcl 8.X or higher" features because those tests
# would not be in the test suite if we did not support
# that particular feature, regardless of the language
# version.
#
if {[isEagle]} then {
#
# NOTE: Process each "known" Tcl version, adding each of
# the "feature" constraints (i.e. since this is an
# Eagle test suite infrastructure package).
#
foreach tclVersion(1) $tclVersions {
set version(1) [getDotlessVersion $tclVersion(1)]
addConstraint [appendArgs tcl $version(1) Feature]
}
}
#
# NOTE: Process each "known" Tcl version, checking for an
# exact match with the running Tcl version. When an
# exact match is found, add appropriate constraints.
#
foreach tclVersion(1) $tclVersions {
#
# NOTE: Does the running Tcl version match this "known"
# Tcl version exactly?
#
if {$::tcl_version eq [getDottedVersion $tclVersion(1)]} then {
#
# NOTE: Yes, it does. First, add the "exact" match
# constraint. There can be only one of these.
#
addConstraint [appendArgs \
tcl [getDotlessVersion $tclVersion(1)]]
#
# NOTE: Next, process each of the "known" Tcl versions
# less than or equal to the running Tcl version,
# while adding both the "feature" and "or higher"
# constraints. There will always be at least one
# of these.
#
foreach tclVersion(2) [filterKnownVersions \
$tclVersions "" $tclVersion(1)] {
set version(2) [getDotlessVersion $tclVersion(2)]
addConstraint [appendArgs tcl $version(2) Feature]
addConstraint [appendArgs tcl $version(2) OrHigher]
}
#
# NOTE: Finally, process each of the "known" Tcl versions
# greater than or equal to the running Tcl version,
# while adding the "or lower" constraints. There
# will always be at least one of these.
#
foreach tclVersion(3) [filterKnownVersions \
$tclVersions $tclVersion(1) ""] {
set version(3) [getDotlessVersion $tclVersion(3)]
addConstraint [appendArgs tcl $version(3) OrLower]
}
#
# NOTE: There can be only one exact Tcl version match;
# therefore, we are done.
#
break
}
}
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 checkForSubCommand { channel names } {
tputs $channel [appendArgs "---- checking for sub-command \"" $names \
"\"... "]
#
# NOTE: Is the sub-command available? The list of names must have
# exactly two elements. The first element must be the command
# name and the second element must be the sub-command name.
#
if {[llength $names] == 2} then {
set commandName [lindex $names 0]
set subCommandName [lindex $names 1]
if {[isEagle]} then {
if {[catch {
#
# NOTE: For Eagle, use the [info subcommands] sub-command.
#
info subcommands $commandName
} subCommands] == 0} then {
if {[lsearch -exact -- $subCommands $subCommandName] != -1} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs \
subCommand. $commandName . $subCommandName]
#
# NOTE: Show that the sub-command was found.
#
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
} elseif {$::tcl_version >= 8.5} then {
if {[catch {
#
# NOTE: For Tcl 8.5+, use the [namespace ensemble] sub-command.
#
namespace ensemble configure $commandName
} subCommands] == 0} then {
foreach {name value} [getDictionaryValue $subCommands -map] {
if {$name eq $subCommandName} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint [appendArgs \
subCommand. $commandName . $subCommandName]
#
# NOTE: Show that the sub-command was found.
#
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
}
}
}
tputs $channel no\n
}
proc checkForEFormat { channel } {
tputs $channel "---- checking for \"eformat\" support... "
if {[catch {
#
# HACK: This test was stolen directly from the native Tcl source
# file "library/tcltest/tcltest.tcl", which is part of the
# "tcltest" package.
#
if {[isEagle]} then {
expr {
[string equal [format %.0e 5e-5] 5e-05] && \
[string equal [format %#.5g 0] 0.0000]
}
} else {
expr {
[string equal [format %g 5e-5] 5e-05] && \
[string equal [format %#.5g 0] 0.0000]
}
}
} eformat] == 0 && [string is true -strict $eformat]} then {
addConstraint eformat
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).
#
if {[catch {namespace enable} enabled] == 0} then {
set available true
addConstraint namespaces.available
} else {
set available false
addConstraint namespaces.unavailable
}
#
# 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 {[string is true -strict $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 {
#
# 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 checkForTestNamePrefix { channel } {
tputs $channel "---- checking for test name prefix... "
if {[info exists ::test_name_prefix] && \
[string length $::test_name_prefix] > 0} then {
addConstraint [appendArgs namePrefix. $::test_name_prefix]
tputs $channel [appendArgs $::test_name_prefix \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 checkForTip421 { channel } {
tputs $channel "---- checking for TIP #421... "
#
# NOTE: Is the interpreter TIP #421 ready?
#
if {[catch {
set array(1) one; set list [list]
array for {name value} array {
lappend list $name $value
}
set list
} result] == 0 && $result eq [list 1 one]} then {
addConstraint tip421
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 checkForTip440 { channel } {
tputs $channel "---- checking for TIP #440... "
#
# NOTE: Is the interpreter TIP #440 ready?
#
if {[catch {set ::tcl_platform(engine)} engine] == 0} then {
addConstraint tip440
tputs $channel [appendArgs "yes (" $engine ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForTip461 { channel } {
tputs $channel "---- checking for TIP #461... "
#
# NOTE: Is the interpreter TIP #461 ready?
#
if {[catch {
set expr(ge) {int("abc" ge "abc")}
set expr(gt) {int("abc" gt "abc")}
set expr(le) {int("abc" le "abc")}
set expr(lt) {int("abc" lt "abc")}
list [expr $expr(ge)] [expr $expr(gt)] \
[expr $expr(le)] [expr $expr(lt)]
}] == 0} then {
addConstraint tip461
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip463 { channel } {
tputs $channel "---- checking for TIP #463... "
#
# NOTE: Is the interpreter TIP #463 ready?
#
if {[catch {
regsub -command . . list
}] == 0} then {
addConstraint tip463
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTip471 { channel } {
tputs $channel "---- checking for TIP #471... "
#
# NOTE: Is the interpreter TIP #471 ready?
#
catch {info linkedname} error
if {[string match {wrong # args: should be "*} $error]} then {
addConstraint tip471
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 {![isTestMono] || ![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 checkForProcessorIntensive { channel } {
tputs $channel "---- checking for processor intensive testing... "
#
# NOTE: Are we allowed to do processor intensive testing?
#
if {![info exists ::no(processorIntensive)]} then {
addConstraint maybeProcessorIntensive
addConstraint processorIntensive
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTimeIntensive { channel } {
tputs $channel "---- checking for time intensive testing... "
#
# NOTE: Are we allowed to do time intensive testing?
#
if {![info exists ::no(timeIntensive)]} then {
addConstraint maybeTimeIntensive
addConstraint timeIntensive
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForFullTest { channel } {
tputs $channel "---- checking for full testing... "
#
# NOTE: Are we allowed to do full testing (i.e. to run rarely
# needed tests)?
#
if {![info exists ::no(fullTest)]} then {
addConstraint fullTest
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 && \
[string is true -strict $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 checkForStackSize { channel } {
tputs $channel "---- checking for stack size... "
#
# NOTE: Are we allowed to do stack size testing?
#
if {![info exists ::no(stackSize)]} then {
if {[isEagle]} then {
#
# NOTE: Attempt to query for the executable stack size.
#
if {[catch {
set reserve [object invoke -create UIntPtr Zero]
set commit [object invoke -create UIntPtr Zero]
object invoke -flags +NonPublic \
Eagle._Components.Private.FileOps \
GetPeFileStackReserveAndCommit \
[info nameofexecutable] reserve commit
set reserve; # primitive, already numeric.
} stackSize] == 0 && \
[string is integer -strict $stackSize] && $stackSize > 0} then {
addConstraint [appendArgs stackSize.0x [format %x $stackSize]]
tputs $channel [appendArgs "yes (" $stackSize ")\n"]
} else {
tputs $channel no\n
}
} else {
#
# NOTE: There is no cross-platform way to check this in
# native Tcl.
#
addConstraint stackSize.unlimited; # TODO: Fix me?
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 {successOnly false} } {
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.
#
set reason unknown
if {[canPing reason]} 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 ($successOnly ? [list Success] : \
[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 [appendArgs $reason \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 checkForSecurity { channel } {
tputs $channel "---- checking for security... "
if {[catch {
object invoke -flags +NonPublic Interpreter.GetActive HasSecurity
} security] == 0} then {
if {[string is true -strict $security]} then {
addConstraint security.enabled
tputs $channel yes\n
} else {
addConstraint security.disabled
tputs $channel no\n
}
} else {
addConstraint security.unavailable
tputs $channel unavailable\n
}
}
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 && [isNonNullObjectHandle $strongName]} 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 checkForStrongNameKey { channel } {
tputs $channel "---- checking for strong name key... "
if {[catch {info engine PublicKeyToken} publicKeyToken] == 0 && \
[string length $publicKeyToken] > 0} then {
#
# NOTE: Add a test constraint for this specific strong name key.
#
addConstraint [appendArgs strongName. $publicKeyToken]
#
# NOTE: Show the strong name key that we found.
#
tputs $channel [appendArgs "yes (" $publicKeyToken ")\n"]
#
# BUGBUG: Tcl 8.4 does not seem to like this expression because it
# contains the "ni" operator added in Tcl 8.5 (and Tcl 8.4
# tries to compile it even though it will only be evaluated
# in Eagle).
#
set expr {$publicKeyToken ni \
"29c6297630be05eb 1e22ec67879739a2 358030063a832bc3"}
if {[expr $expr]} then {
#
# NOTE: The Eagle core library is strong name signed with a key that
# is not official. This is also not an error, per se; however,
# it may cause some tests to fail and it should be reported to
# the user and noted in the test suite log file.
#
addConstraint strongName.unofficial
#
# NOTE: Unless forbidden, issue and log a warning.
#
if {![info exists no(warningForStrongNameKey)] && \
![haveConstraint quiet]} then {
tputs $channel [appendArgs \
"==== WARNING: unofficial Eagle strong name signature " \
"detected: " $publicKeyToken \n]
}
} else {
#
# NOTE: Several tests require one of the official strong name keys to
# be used in order for them to pass.
#
addConstraint strongName.official
tputs $channel [appendArgs \
"---- official Eagle strong name signature detected: " \
$publicKeyToken \n]
}
} else {
#
# NOTE: The Eagle core library is not signed with a strong name key.
# This is not an error, per se; however, it may cause selected
# tests to fail and it should be reported to the user and noted
# in the test suite log file.
#
addConstraint strongName.none
#
# NOTE: Show that we did not find a strong name key.
#
tputs $channel no\n
#
# NOTE: Unless forbidden, issue and log a warning.
#
if {![info exists no(warningForStrongNameKey)] && \
![haveConstraint quiet]} then {
tputs $channel \
"==== WARNING: no Eagle strong name signature detected...\n"
}
}
}
proc checkForCertificate { channel } {
tputs $channel "---- checking for certificate... "
if {[catch {
object invoke Interpreter.GetActive GetCertificate
} certificate] == 0 && [isNonNullObjectHandle $certificate]} then {
#
# NOTE: Yes, it appears that the core library was signed with a
# code-signing certificate.
#
addConstraint certificate
#
# NOTE: Attempt to query the subject from the certificate.
#
if {[catch {
object invoke $certificate Subject
} subject] || [string length $subject] == 0} then {
#
# TODO: No certificate subject, better handling here?
#
set subject unknown
}
tputs $channel [appendArgs "yes (" $subject ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForCompileCSharp { channel } {
tputs $channel "---- checking for test use of C# compiler... "
if {![info exists ::no(compileCSharp)] && \
[doesCompileCSharpWork]} then {
addConstraint compileCSharp
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForAdministrator { channel } {
tputs $channel "---- checking for administrator... "
if {[isTestAdministrator]} 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 {[string is true -strict $open]} then {
addConstraint hostIsOpen
tputs $channel open\n
} else {
if {[catch {host redirected Input} redirected] == 0} then {
if {[string is true -strict $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 {[info tid] == [set threadId [info ptid]]} 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 && [isNonNullObjectHandle $appDomain]} then {
if {[catch {
object invoke $appDomain IsDefaultAppDomain
} default] || [string length $default] == 0} then {
set default false
}
if {[catch {object invoke $appDomain Id} id] || \
[string length $id] == 0} then {
set id unknown
}
if {$default} then {
addConstraint defaultAppDomain
tputs $channel [appendArgs "yes (" $id ")\n"]
} else {
tputs $channel [appendArgs "no (" $id ")\n"]
}
} else {
tputs $channel [appendArgs "no (null)\n"]
}
}
proc checkForRuntime { channel } {
tputs $channel "---- checking for runtime... "
#
# NOTE: Are we running inside Mono -OR- on .NET Core (regardless
# of operating system)?
#
if {[isTestDotNetCore]} then {
#
# NOTE: Yes, it appears that we are running on .NET Core.
#
addConstraint dotNetCore; # running on .NET Core.
addConstraint dotNetOrDotNetCore
addConstraint dotNetCoreOrShell
#
# NOTE: We do not want to skip Mono bugs on .NET Core.
#
addKnownMonoConstraints true; # running on .NET Core.
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : ".NET Core"}] \n]
} elseif {[isTestMono]} then {
#
# NOTE: Yes, it appears that we are running inside Mono.
#
addConstraint mono; # running on Mono.
addConstraint monoOrDotNetCore
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : "Mono"}] \n]
} else {
#
# NOTE: It appears that we are running on the full .NET.
#
addConstraint dotNet; # running on .NET.
addConstraint dotNetOrDotNetCore
#
# NOTE: We do not want to skip Mono bugs on .NET.
#
addKnownMonoConstraints true; # 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 [getMajorMinorVersion \
$::eagle_platform(imageRuntimeVersion)]
#
# 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 [getMajorMinorVersion \
$::eagle_platform(frameworkVersion)]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [getDotlessVersion $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 checkForMatchingFrameworkVersion { channel } {
tputs $channel "---- checking for matching framework version... "
if {[info exists ::eagle_platform(frameworkVersion)] && \
[string length $::eagle_platform(frameworkVersion)] > 0} then {
if {[info exists ::eagle_platform(imageRuntimeVersion)] && \
[string length $::eagle_platform(imageRuntimeVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the versions only.
#
set dotVersion(1) [getMajorMinorVersion \
$::eagle_platform(frameworkVersion)]
set dotVersion(2) [getMajorMinorVersion \
$::eagle_platform(imageRuntimeVersion)]
#
# NOTE: Remove single leading "v" characters, if applicable.
#
if {[string index $dotVersion(1) 0] eq "v"} then {
set dotVersion(1) [string range $dotVersion(1) 1 end]
}
if {[string index $dotVersion(2) 0] eq "v"} then {
set dotVersion(2) [string range $dotVersion(2) 1 end]
}
#
# NOTE: Now create a version string for use in the constraint
# name (remove the periods).
#
set version(1) [string map [list . ""] $dotVersion(1)]
#
# NOTE: Check for an exact match between the image runtime
# version and the framework version.
#
if {$dotVersion(1) eq $dotVersion(2)} then {
#
# NOTE: Yes, the image runtime version matches the framework.
#
addConstraint matchFramework
addConstraint [appendArgs matchFramework $version(1)]
addConstraint dotNetMatchFramework
addConstraint [appendArgs dotNetMatchFramework $version(1)]
addConstraint monoMatchFramework
addConstraint [appendArgs monoMatchFramework $version(1)]
addConstraint dotNetCoreMatchFramework
addConstraint [appendArgs dotNetCoreMatchFramework $version(1)]
tputs $channel yes\n
} else {
if {[isTestDotNetCore]} then {
addConstraint dotNetMatchFramework
addConstraint [appendArgs dotNetMatchFramework $version(1)]
addConstraint monoMatchFramework
addConstraint [appendArgs monoMatchFramework $version(1)]
} elseif {[isTestMono]} then {
addConstraint dotNetMatchFramework
addConstraint [appendArgs dotNetMatchFramework $version(1)]
addConstraint dotNetCoreMatchFramework
addConstraint [appendArgs dotNetCoreMatchFramework $version(1)]
} else {
addConstraint monoMatchFramework
addConstraint [appendArgs monoMatchFramework $version(1)]
addConstraint dotNetCoreMatchFramework
addConstraint [appendArgs dotNetCoreMatchFramework $version(1)]
}
tputs $channel no\n
}
} else {
tputs $channel "no, missing image runtime version\n"
}
} else {
tputs $channel "no, missing framework version\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 [getMajorMinorVersion \
$::eagle_platform(runtimeVersion)]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list . ""] $dotVersion]
if {[isTestDotNetCore]} 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 the .NET Core. Keep track of the
# specific version for usage in test constraints.
#
addConstraint [appendArgs dotNetCore $version]
addConstraint [appendArgs dotNetCore $version OrHigher]
}
#
# NOTE: We do not want to skip any Mono bugs on .NET Core. Add
# the necessary constraints for each version of Mono we
# know about.
#
addKnownMonoConstraints false; # running on .NET.
} elseif {[isTestMono]} 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.
#
addKnownMonoConstraints false; # running on .NET.
}
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]
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
tputs $channel "no, unknown\n"
}
}
proc checkForTestCallStack { channel } {
tputs $channel "---- checking for test call stack... "
#
# NOTE: Search for a call frame with associated arguments.
# At this point, there must be at least one such call
# frame (this one). Therefore, this loop will always
# terminate.
#
set index 0; set arguments [list]
set script {info level [info level]}
while {1} {
set level [appendArgs ## $index]
if {[catch {uplevel $level $script} arguments] == 0} then {
break
}
incr index
}
#
# NOTE: Grab the command name from the arguments, if any.
#
set command [expr {
[llength $arguments] > 0 ? [lindex $arguments 0] : ""
}]
#
# HACK: Make sure the call stack does not end up confusing
# the tests that rely on absolute call frames. The
# [runTestPrologue] is allowed here because it will
# not be active on the call stack at the point the
# tests are actually run. Actually, the same thing
# goes for [checkForTestCallStack] as well.
#
if {$command in \
[list runTestPrologue checkForTestCallStack]} then {
addConstraint testCallStack
tputs $channel [appendArgs "yes (\"" $command "\")\n"]
#
# NOTE: We are done here, return now.
#
return
}
tputs $channel [appendArgs "no (\"" $command "\")\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 && [string is true -strict $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 testForDynamicLoading { {fileName ""} } {
if {[catch {
if {[string length $fileName] == 0} then {
if {[isWindows]} then {
set fileName kernel32; # HACK: Always pre-loaded?
} elseif {[info exists ::tcl_platform(os)] && \
$::tcl_platform(os) eq "Darwin"} then {
set fileName libdl.dylib; # TODO: Good default?
} else {
set fileName libdl.so; # TODO: Good default?
}
}
set error null
object invoke -flags +NonPublic \
Eagle._Components.Private.NativeOps TestLoadLibrary \
$fileName error
} code] == 0 && $code eq "Ok"} then {
return true
}
return false
}
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] || [testForDynamicLoading]} 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 {![isTestMono]} 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 checkForLibraryAssemblyName { channel } {
tputs $channel "---- checking for library assembly name... "
#
# NOTE: What is the name of the core library assembly? Normally,
# this will be "Eagle"; however, it could be something else.
#
if {[catch {getTestAssemblyName} assemblyName] == 0} then {
addConstraint [appendArgs libraryAssemblyName. $assemblyName]
tputs $channel [appendArgs "yes (" $assemblyName ")\n"]
} else {
tputs $channel no\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 checkForExcelUsable { channel } {
tputs $channel "---- checking for usable instance of Excel... "
#
# NOTE: As of this writing, this check is only supported on Windows.
#
if {[isWindows]} then {
#
# NOTE: This constraint check must run after the interop assembly for
# Excel has been detected, because this check makes use of it.
#
if {[haveConstraint Microsoft.Office.Interop.Excel]} then {
#
# NOTE: This constraint check requires the (optional) interpreter
# isolation feature of Eagle in order to keep the primary
# interpreter and AppDomain tidy. It also requires access
# to native Windows support in order to use the [info hwnd]
# sub-command.
#
if {[haveConstraint compile.ISOLATED_INTERPRETERS] && \
[haveConstraint compile.NATIVE] && \
[haveConstraint compile.WINDOWS]} then {
#
# NOTE: Allocate a temporary file name that can be used to save
# the Excel spreadsheet. This name will be provided to a
# child interpreter for its use -AND- cleaned up by this
# interpreter before exiting this procedure.
#
set tempName(1) [getTemporaryFileName]
#
# NOTE: Use a try/finally block to cleanup temporary files.
#
try {
if {[catch {
#
# NOTE: In an attempt to limit the assemblies loaded into the
# primary AppDomain, create an isolated interpreter.
#
set interp [interp create -isolated]
#
# NOTE: Give the newly created (isolated) interpreter a means
# to set variables in the parent (this) interpreter.
#
interp alias $interp pset {} set; # parent set
#
# NOTE: Give the newly created (isolated) interpreter a base
# name for a temporary file.
#
interp set $interp tempName(1) $tempName(1)
#
# NOTE: Evaluate all the Excel interop assembly related code
# in the other AppDomain.
#
interp eval $interp {
#
# NOTE: First, attempt to load the Excel interop assembly.
# If this fails, we cannot continue and Excel is not
# considered usable.
#
set assembly [object load -import -declare \
Microsoft.Office.Interop.Excel]
#
# NOTE: Next, attempt to run the Excel application using
# its automation object model. If this fails, we
# cannot continue and Excel is not considered usable.
#
set application [object create -alias \
Microsoft.Office.Interop.Excel.ApplicationClass]; # run
#
# NOTE: Next, attempt to extract the process ID associated
# with the Excel application window. This is used to
# help make sure the running Excel instance is closed
# after our testing is complete. Generally, this will
# not fail because we know the [info hwnd] sub-command
# should be available, due to define constant checks.
#
pset pid [getDictionaryValue \
[info hwnd [$application Hwnd]] processId]
#
# NOTE: Next, attempt to make sure that the Excel instance
# is not visible and will not display alerts/prompts.
# If this fails, Excel is not considered usable.
#
$application Visible false
$application DisplayAlerts false
#
# NOTE: Next, create a value of an enumerated type exposed
# by the Excel automation object model so that we can
# add a new workbook. Generally, this does not fail.
# If this fails, Excel is not considered usable.
#
set enumValue [object invoke -create \
Enum Parse XlWBATemplate xlWBATWorksheet]
#
# NOTE: Next, attempt to add a new workbook. If this fails,
# Excel is not considered usable.
#
set workbook [object invoke -alias \
$application.Workbooks Add $enumValue]
#
# NOTE: Setup a temporary file name that can be used to save
# the Excel spreadsheet.
#
pset fileName [set fileName [file nativename [appendArgs \
$tempName(1) .xls]]]
#
# NOTE: Next, attempt to save a new workbook. If this fails,
# Excel is not considered usable.
#
$workbook SaveAs $fileName
#
# NOTE: Next, attempt to close Excel. If this fails, Excel
# is not considered usable.
#
$application Quit; # close
#
# NOTE: Finally, cleanup our local state just to be tidy.
#
unset workbook enumValue application assembly; # dispose
}
} result] == 0} then {
#
# NOTE: It appears the Excel instance is usable.
#
addConstraint excel.usable
#
# NOTE: Show that a usable Excel instance was found.
#
tputs $channel yes\n
} else {
#
# NOTE: This is the list of error message patterns that may
# indicate a trial version of Excel is being used.
#
set patterns [list \
"* 0x800AC472*" "* 0x800A03EC*" \
"* application has expired.*"]
#
# NOTE: Check each error message pattern. Upon finding any
# match, mark Excel as unusable due to being a trial
# edition and then stop.
#
foreach pattern $patterns {
#
# TODO: For now, just use [string match] here; eventually,
# regular expressions may be needed.
#
if {[string match $pattern $result]} then {
#
# NOTE: It appears that Excel is a trial edition.
#
addConstraint excel.trial
#
# NOTE: Show that the Excel trial edition was found.
#
tputs $channel "no, trial\n"
#
# NOTE: We are done here, return now.
#
return
}
}
#
# NOTE: It appears the Excel instance is not usable.
#
addConstraint excel.unusable
#
# NOTE: Show that a unusable Excel instance was found.
#
tputs $channel "no, broken\n"
}
} finally {
#
# NOTE: Make sure the isolated interpreter is deleted if it was
# actually created.
#
if {[info exists interp] && [interp exists $interp]} then {
catch {interp delete $interp}
}
#
# NOTE: Make sure the Excel process is (forcibly) closed if it
# is still running at this point.
#
if {[info exists pid] && $pid in [getProcesses excel]} then {
catch {kill -force $pid}
}
#
# NOTE: Make sure the temporary spreadsheet file is deleted if
# it was actually created.
#
if {[info exists fileName] && [file exists $fileName]} then {
catch {file delete $fileName}
}
#
# NOTE: Make sure the dummy temporary files are cleaned up.
#
if {[array exists tempName]} then {
foreach tempFileName [array values tempName] {
if {[file exists $tempFileName]} then {
catch {file delete $tempFileName}
}
}
}
}
} else {
tputs $channel "unknown, missing optional feature\n"
}
} else {
tputs $channel "unknown, no Excel interop assembly\n"
}
} else {
tputs $channel "unknown, not running on Windows\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: Found one? Ok, 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?
#
foreach tclVersion [lreverse [getKnownTclVersions]] {
if {$dotVersion >= [getDottedVersion $tclVersion]} then {
addConstraint [appendArgs \
tclLibrary [getDotlessVersion $tclVersion]]
#
# NOTE: For now, there can be only one Tcl library match;
# therefore, we are done.
#
break
}
}
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 && \
[string is true -strict $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}
} dotVersion] == 0 && [regexp -- {^\d+\.\d+$} $dotVersion]} then {
addConstraint [appendArgs \
tclReady [getDotlessVersion $dotVersion]]
#
# 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".
#
foreach tclVersion [lreverse [getKnownTclVersions]] {
set version [getDotlessVersion $tclVersion]
if {[haveConstraint [appendArgs tclLibrary $version]] && \
$dotVersion >= [getDottedVersion $tclVersion]} then {
addConstraint [appendArgs tclReadyOrLibrary $version]
#
# NOTE: For now, there can be only one Tcl library match;
# therefore, we are done.
#
break
}
}
tputs $channel [appendArgs "yes (" $dotVersion ")\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".
#
foreach tclVersion [lreverse [getKnownTclVersions]] {
set version [getDotlessVersion $tclVersion]
if {[haveConstraint [appendArgs tclLibrary $version]]} then {
addConstraint [appendArgs tclReadyOrLibrary $version]
#
# NOTE: For now, there can be only one Tcl library match;
# therefore, we are done.
#
break
}
}
tputs $channel no\n
}
}
proc checkForTclSelect { channel } {
tputs $channel "---- checking for Tcl library selection... "
if {[catch {tcl select -architecture} select] == 0} then {
#
# NOTE: Yes, native Tcl is "probably loadable".
#
addConstraint tclSelect
#
# NOTE: Ok, attempt to determine the selected Tcl version.
#
if {[catch {
getDictionaryValue $select version
} version] == 0 && [regexp -- {^\d+\.\d+$} $version]} then {
addConstraint [appendArgs \
tclSelect [string map [list . ""] $version]]
tputs $channel [appendArgs "yes (" $select ")\n"]
} else {
#
# NOTE: The Tcl library is "probably loadable"; however, we have
# no idea what version it actually is.
#
tputs $channel yes\n
}
} else {
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] && \
![info exists ::no(getTclVersionForTclShell)] && \
[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] && \
![info exists ::no(getTkVersionForTclShell)] && \
[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.11 3.10 3.9 3.8 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 "yes (" $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 . [getMajorMinorVersion $version]]
} 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 checkForNetFx20ServicePack { channel } {
tputs $channel "---- checking for .NET Framework 2.0 Service Pack... "
#
# 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 2.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\v2.0.50727}]
#
# NOTE: Attempt to fetch the .NET Framework 2.0 "SP" value from the
# servicing registry hive. If this value does not exist -OR-
# is less than 1, then no .NET Framework 2.0 service pack is
# installed. If this raises a script error, that will almost
# certainly cause the result to be a non-integer, thus failing
# the check below.
#
catch {
object invoke Microsoft.Win32.Registry GetValue $key SP null
} servicePack
if {[string is integer -strict $servicePack]} then {
#
# NOTE: Service packs are always cumulative; therefore, add test
# constraints for all service pack levels up to the one that
# is actually installed.
#
for {set level 0} {$level <= $servicePack} {incr level} {
addConstraint [appendArgs dotNet20Sp $level OrHigher]
}
#
# NOTE: Also add the "exact" service pack test constraint even
# though it should almost never be used.
#
addConstraint [appendArgs dotNet20Sp $servicePack]
#
# NOTE: Show the "servicePack" value we found in the registry.
#
tputs $channel [appendArgs "yes (" $servicePack ")\n"]
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc getFrameworkSetup451Value {} {
#
# NOTE: Check if we are running on Windows 8.1.
#
# BUGBUG: Is exact matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) == 6.3} then {
#
# NOTE: We are running on Windows 8.1, return the special value.
#
return 378675
}
#
# NOTE: We are not running on Windows 8.1, return the normal value.
#
return 378758
}
proc getFrameworkSetup46Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 393295
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 393297
}
proc getFrameworkSetup461Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0 && \
[haveTclPlatformOsExtraUpdateName "November Update"]} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 394254; # BUGBUG: November Update only?
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 394271
}
proc getFrameworkSetup462Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0 && \
[haveTclPlatformOsExtraUpdateName "Anniversary Update"]} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 394802; # BUGBUG: Anniversary Update only?
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 394806
}
proc getFrameworkSetup47Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0 && \
[haveTclPlatformOsExtraUpdateName "Creators Update"]} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 460798; # BUGBUG: Creators Update only?
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 460805
}
proc getFrameworkSetup471Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0 && \
[haveTclPlatformOsExtraUpdateName "Fall Creators Update"]} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 461308; # BUGBUG: Fall Creators Update only?
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 461310
}
proc getFrameworkSetup472Value {} {
#
# NOTE: Check if we are running on Windows 10 or later.
#
# BUGBUG: Is greater-than-or-equal-to matching correct here?
#
if {[isWindows] && [info exists ::tcl_platform(osVersion)] && \
$::tcl_platform(osVersion) >= 10.0 && \
[haveTclPlatformOsExtraUpdateName "April 2018 Update"]} then {
#
# NOTE: We are running on Windows 10, return the special value.
#
return 461808; # BUGBUG: Fall Creators Update only?
}
#
# NOTE: We are not running on Windows 10, return the normal value.
#
return 461814
}
proc checkForNetFx4x { channel } {
tputs $channel "---- checking for .NET Framework 4.x... "
#
# 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. If this raises a script error, that will almost
# certainly cause the result to be a non-integer, thus failing
# the check below.
#
catch {
object invoke Microsoft.Win32.Registry GetValue $key Release null
} release
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
# (or 378675 for Windows 8.1), then the .NET Framework 4.5.1
# is installed. However, if the "release" value is also
# greater than or equal to 379893, then the .NET Framework
# 4.5.2 is installed, which is an in-place upgrade to 4.5.1
# (and 4.5). If the "release" value is also greater than or
# equal to 393297 (393295 on Windows 10), then the .NET
# Framework 4.6 is installed, which is an in-place upgrade
# to 4.5.x. Similar handling is necessary for the .NET
# Framework 4.6.1, 4.6.2, 4.7, 4.7.1, and 4.7.2. For more
# information, see:
#
# https://msdn.microsoft.com/en-us/library/hh925568.aspx
#
if {$release >= [getFrameworkSetup472Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46OrHigher
addConstraint dotNet461OrHigher
addConstraint dotNet462OrHigher
addConstraint dotNet47OrHigher
addConstraint dotNet471OrHigher
addConstraint dotNet472
addConstraint dotNet472OrHigher
set version 4.7.2
} elseif {$release >= [getFrameworkSetup471Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46OrHigher
addConstraint dotNet461OrHigher
addConstraint dotNet462OrHigher
addConstraint dotNet47OrHigher
addConstraint dotNet471
addConstraint dotNet471OrHigher
set version 4.7.1
} elseif {$release >= [getFrameworkSetup47Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46OrHigher
addConstraint dotNet461OrHigher
addConstraint dotNet462OrHigher
addConstraint dotNet47
addConstraint dotNet47OrHigher
set version 4.7
} elseif {$release >= [getFrameworkSetup462Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46OrHigher
addConstraint dotNet461OrHigher
addConstraint dotNet462
addConstraint dotNet462OrHigher
set version 4.6.2
} elseif {$release >= [getFrameworkSetup461Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46OrHigher
addConstraint dotNet461
addConstraint dotNet461OrHigher
set version 4.6.1
} elseif {$release >= [getFrameworkSetup46Value]} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452OrHigher
addConstraint dotNet46
addConstraint dotNet46OrHigher
set version 4.6
} elseif {$release >= 379893} then {
addConstraint dotNet451OrHigher
addConstraint dotNet452
addConstraint dotNet452OrHigher
set version 4.5.2
} elseif {$release >= [getFrameworkSetup451Value]} 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 checkForVisualStudioViaRegistry { channel } {
tputs $channel "---- checking for Visual Studio using registry... "
#
# NOTE: Initially, no versions of Visual Studio have been found.
#
set visualStudioVersions [list]
#
# 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 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 detection
# of using the registry.
#
set versions [list [list 8.0 2005] [list 9.0 2008] \
[list 10.0 2010] [list 11.0 2012] [list 12.0 2013] \
[list 14.0 2015]]
#
# 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.
#
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} then {
#
# NOTE: Does the directory name look valid and does it
# actually exist?
#
if {[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
# suite 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 ", \"" \
[expr {[info exists ::test_visual_studio] ? \
$::test_visual_studio : "<none>"}] "\")\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 && [string is true -strict $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 && [string is true -strict $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 {[isNonNullObjectHandle $debugger]} then {
catch {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 {[isNonNullObjectHandle $debugger]} then {
catch {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 {[isNonNullObjectHandle $interp]} then {
catch {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 \
getKnownBuildTypes getKnownCompileOptions getKnownMonoVersions \
addKnownMonoConstraints getDotNetCoreLibPathDirectoryNameOnly \
lpermute alwaysFullInterpReady canExecComSpec canExecWhoAmI \
canExecTclShell canExecFossil canExecVsWhere isTestMono \
isTestDotNetCore isTestAdministrator canPing cleanConstraintName \
cleanPackageName haveTclPlatformOsExtraUpdateName \
checkForTestSuiteFiles checkForPlatform checkForWindowsVersion \
checkForOperatingSystemUpdate checkForScriptLibrary checkForVariable \
checkForTclOptions checkForWindowsCommandProcessor checkForPackage \
checkForFossil checkForVisualStudioViaVsWhere checkForEagle \
checkForSymbols checkForLogFile checkForGaruda checkForShell \
checkForOfficialStableReleaseInProgress checkForDebug checkForTk \
checkForVersion checkForCommand checkForSubCommand checkForEFormat \
checkForNamespaces checkForTestExec checkForTestMachine \
checkForTestPlatform checkForTestConfiguration checkForTestNamePrefix \
checkForTestSuffix checkForFile checkForPathFile checkForNativeCode \
checkForTip127 checkForTip194 checkForTip207 checkForTip241 \
checkForTip285 checkForTip405 checkForTip421 checkForTip426 \
checkForTip429 checkForTip440 checkForTip461 checkForTip463 \
checkForTip471 checkForTiming checkForPerformance checkForBigLists \
checkForProcessorIntensive checkForTimeIntensive checkForFullTest \
checkForMemoryIntensive checkForStackIntensive checkForStackSize \
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"}]
}