############################################################################### # # 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 {} { if {[info exists ::test_well_known(buildTypes)]} then { return $::test_well_known(buildTypes) } return [list \ NetFx20 NetFx35 NetFx40 NetFx45 NetFx451 \ NetFx452 NetFx46 NetFx461 NetFx462 NetFx47 \ NetFx471 NetFx472 NetFx48 NetStandard20 Bare \ LeanAndMean Database MonoOnUnix Development] } proc getKnownCompileOptions {} { if {[info exists ::test_well_known(compileOptions)]} then { return $::test_well_known(compileOptions) } 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_48 \ 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 SCRIPT_ARGUMENTS 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 UNSAFE \ 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 getKnownWindowsVersions { {force false} } { if {[info exists ::test_well_known(windowsVersions)]} then { return $::test_well_known(windowsVersions) } if {$force || ![info exists ::no(windowsVersions)]} then { return [list [list 3 1] [list 3 5] [list 3 51] [list 4 0] [list 5 0] \ [list 5 1] [list 5 2] [list 6 0] [list 6 1] [list 6 2] [list 6 3] \ [list 10 0]] } else { return [list] } } 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/ # https://www.mono-project.com/docs/about-mono/versioning/ # # TODO: This list should be manually updated when a new version of # the Mono runtime is released -OR- when one is skipped (e.g. # 5.6 and 5.22). # if {[info exists ::test_well_known(monoVersions)]} then { return $::test_well_known(monoVersions) } 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] [list 5 18] \ [list 5 20] [list 6 0] [list 6 4] [list 6 6]] } 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 getKnownDotNetCoreVersions { {force false} } { # # NOTE: This job of this procedure is to return the list of "known" # versions of .NET Core supported by the test suite infrastructure. # # https://en.wikipedia.org/wiki/.NET_Core # https://github.com/dotnet/core/releases # # TODO: This list should be manually updated when a new version of # the .NET Core runtime is released. # if {[info exists ::test_well_known(dotNetCoreVersions)]} then { return $::test_well_known(dotNetCoreVersions) } if {$force || ![info exists ::no(dotNetCoreVersions)]} then { return [list [list 2 0] [list 2 1] [list 2 2] [list 3 0]] } else { return [list] } } proc addKnownDotNetCoreConstraints { 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 .NET Core # that we know about. # foreach dotNetCoreVersion [getKnownDotNetCoreVersions] { set constraintVersion [join $dotNetCoreVersion ""] addConstraint [appendArgs dotNetCoreToDo $constraintVersion] addConstraint [appendArgs dotNetCoreToDo $constraintVersion Only] addConstraint [appendArgs dotNetCoreBug $constraintVersion] addConstraint [appendArgs dotNetCoreBug $constraintVersion Only] addConstraint [appendArgs dotNetCoreCrash $constraintVersion] addConstraint [appendArgs dotNetCoreCrash $constraintVersion Only] } } else { # # NOTE: Also add just the generic .NET Core constraints that do not # have a trailing version. # set constraints [list dotNetCoreToDo dotNetCoreBug dotNetCoreCrash] 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 {[info exists ::test_well_known(tclVersions)]} then { return $::test_well_known(tclVersions) } 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 "fsutil" 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 canExecFsUtil {} { if {[info exists ::no(exec)]} then { return false } if {[info exists ::no(fsutil)]} then { return false } if {[info exists ::no(canExecFsUtil)]} 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. addKnownDotNetCoreConstraints true; # running in native Tcl. addKnownDotNetCoreConstraints 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: Check all the well-known versions of Windows -AND- add # appropriate test constraints. # foreach windowsVersion [getKnownWindowsVersions] { set dotWindowsVersion [getDottedVersion $windowsVersion] if {$osVersion >= $dotWindowsVersion} then { # # NOTE: Start out with the OS name, removing all spaces and # then append the well-known OS version number as well # as the suffix "_OrHigher" to indicate a inexact match. # set version [appendArgs \ [string map [list " " ""] $::tcl_platform(os)] _ \ $dotWindowsVersion _ OrHigher] addConstraint [appendArgs osVersion. $version] } } # # 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 checkForGetInstalledUpdates { channel {populate true} {timeout 60000} } { tputs $channel "---- checking for installed updates support... " if {[info exists ::tcl_platform(osExtra)]} then { # # HACK: When running in Eagle, wait for the "setup" event in # the active interpreter. This event will be signaled # (only) after the "tcl_platform(osExtra)" element has # been fully populated by its dedicated thread. # if {[isEagle]} then { if {[catch { object invoke -flags +NonPublic \ Eagle._Components.Private.PlatformOps \ ShouldPopulateOperatingSystemExtra "" \ false true false true } should] == 0 && $should} then { if {[catch { if {$populate} then { object invoke -flags +NonPublic \ Eagle._Components.Private.PlatformOps \ PopulateOperatingSystemExtra "" \ false true } object invoke -flags +NonPublic \ Interpreter.GetActive WaitSetupEvent \ $timeout } code] || $code ne "Ok"} then { tputs $channel timeout\n return } } else { tputs $channel disabled\n return } } # # HACK: Assume the GetInstalledUpdates method works if the # associated "tcl_platform" element is populated with # the update names. Technically, this check does not # rely on anything specific to Windows; however, the # underlying functionality is currently only present # on Windows. # if {[llength [getDictionaryValue \ $::tcl_platform(osExtra) UpdateNames]] > 0} then { addConstraint getInstalledUpdates tputs $channel yes\n 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] [list 16.0 2019]] # # 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 : ""}] "\")\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 IsAvailable } isAvailable] == 0 && \ [string is true -strict $isAvailable]} 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 # # NOTE: We do not want to skip .NET Core bugs on Mono. # addKnownDotNetCoreConstraints true; # running on Mono. 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 -OR- .NET Core bugs on .NET. # addKnownMonoConstraints true; # running on .NET. addKnownDotNetCoreConstraints 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: 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 .NET Core versions to add test # constraints for. # set dotNetCoreVersions [list] # # NOTE: Check each .NET Core version "known" to the test # suite. # foreach dotNetCoreVersion [getKnownDotNetCoreVersions] { # # NOTE: Check for any .NET Core major version X or higher. # if {$majorVersion >= [lindex $dotNetCoreVersion 0]} then { # # NOTE: Check for any .NET Core major/minor version # higher than X.Y. # if {$majorVersion > [lindex $dotNetCoreVersion 0] || \ $minorVersion > [lindex $dotNetCoreVersion 1]} then { # # NOTE: Add this "known" version of .NET Core. # lappend dotNetCoreVersions $dotNetCoreVersion } } } # # NOTE: Add the necessary constraints for each version of .NET # Core we should NOT skip bugs for. # foreach dotNetCoreVersion $dotNetCoreVersions { set constraintVersion [join $dotNetCoreVersion ""] addConstraint [appendArgs \ dotNetCore $constraintVersion OrHigher] addConstraint [appendArgs \ dotNetCoreToDo $constraintVersion] addConstraint [appendArgs \ dotNetCoreBug $constraintVersion] addConstraint [appendArgs \ dotNetCoreCrash $constraintVersion] } # # NOTE: Check all known versions of .NET Core for an exact match # with the currently running one. # foreach dotNetCoreVersion [getKnownDotNetCoreVersions] { # # NOTE: Check if .NET Core major/minor version is exactly the # one we are currently processing. # set constraintVersion [join $dotNetCoreVersion ""] if {[lindex $dotNetCoreVersion 0] == $majorVersion && \ [lindex $dotNetCoreVersion 1] == $minorVersion} then { # # NOTE: Add test constraints that only apply to this exact # version of .NET Core. # addConstraint [appendArgs \ dotNetCore $constraintVersion Only] } else { # # NOTE: Add test constraints that apply to all versions of # .NET Core except this exact version. # addConstraint [appendArgs \ dotNetCoreToDo $constraintVersion Only] addConstraint [appendArgs \ dotNetCoreBug $constraintVersion Only] addConstraint [appendArgs \ dotNetCoreCrash $constraintVersion Only] } } } # # 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] } } } # # NOTE: We do not want to skip any .NET Core bugs on Mono. Add # the necessary constraints for each version of Mono we # know about. # addKnownDotNetCoreConstraints false; # running on Mono. } 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. addKnownDotNetCoreConstraints 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: First, figure out what the file name for the Garuda DLL is, # if anything. # set fileName [getGarudaDll $machine] if {[string length $fileName] > 0} then { # # NOTE: Next, check if the Garuda DLL is the same platform (i.e. # machine type) as the native Tcl shell. # checkForFile $channel $fileName # # NOTE: Next, check if the Garuda DLL appears to be compatible # with this platform. # tputs $channel [appendArgs \ "---- checking if file \"" $fileName \ "\" matches architecture for current process... "] if {[catch { library matcharchitecture $fileName; # maybe missing command? } match] == 0 && $match} then { addConstraint garudaLibrary tputs $channel yes\n } else { tputs $channel no\n } } } 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 {milliseconds 5000} } { 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 and our milliseconds value. # interp set $interp milliseconds $milliseconds 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: Wait for a bit to make sure that the Excel process # is actually running (?). # after $milliseconds # # 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 \ "* 0x80010001*" "* 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 "" [getTclShellVerbosity] } version] == 0 && $version ne "error" && \ ![string match "error: *" $version]} 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 "" [getTclShellVerbosity] } version] == 0 && $version ne "error" && \ ![string match "error: *" $version]} 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: April 2018 Update only? } # # NOTE: We are not running on Windows 10, return the normal value. # return 461814 } proc getFrameworkSetup48Value {} { # # 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 "May 2019 Update"]} then { # # NOTE: We are running on Windows 10, return the special value. # return 528040; # BUGBUG: May 2019 Update only? } # # NOTE: We are not running on Windows 10, return the normal value. # return 528049 } 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, 4.7.2, and 4.8. For # more information, see: # # https://msdn.microsoft.com/en-us/library/hh925568.aspx # if {$release >= [getFrameworkSetup48Value]} then { addConstraint dotNet451OrHigher addConstraint dotNet452OrHigher addConstraint dotNet46OrHigher addConstraint dotNet461OrHigher addConstraint dotNet462OrHigher addConstraint dotNet47OrHigher addConstraint dotNet471OrHigher addConstraint dotNet472OrHigher addConstraint dotNet48 addConstraint dotNet48OrHigher set version 4.8 } elseif {$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. This no longer works as of the # release of Visual Studio 2017. For Visual Studio 2017 # and beyond, the [checkForVisualStudioViaVsWhere] method # must be used instead. # 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 : ""}] "\")\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 getKnownWindowsVersions \ getKnownMonoVersions addKnownMonoConstraints \ getKnownDotNetCoreVersions addKnownDotNetCoreConstraints \ getDotNetCoreLibPathDirectoryNameOnly lpermute alwaysFullInterpReady \ canExecComSpec canExecWhoAmI canExecTclShell canExecFossil \ canExecVsWhere isTestMono isTestDotNetCore isTestAdministrator canPing \ cleanConstraintName cleanPackageName haveTclPlatformOsExtraUpdateName \ checkForTestSuiteFiles checkForPlatform checkForWindowsVersion \ checkForGetInstalledUpdates 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"}] }