###############################################################################
#
# constraints.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Test Constraints File
#
# Copyright (c) 2007-2010 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 checkForPlatform { channel } {
tputs $channel "---- checking for platform... "
addConstraint $::tcl_platform(platform)
if {![isEagle]} then {
#
# BUGFIX: We do not want to skip any Mono bugs in Tcl.
# Also, fake the culture.
#
set constraints [list monoToDo monoBug monoCrash culture.en_US]
#
# NOTE: Add the necessary constraints for each version
# of Mono we know about.
#
foreach version [list 20 22 24 26 28 210 30] {
addConstraint [appendArgs monoToDo $version]
addConstraint [appendArgs monoBug $version]
addConstraint [appendArgs monoCrash $version]
}
foreach constraint $constraints {
addConstraint $constraint; # running in Tcl.
}
}
tputs $channel [appendArgs $::tcl_platform(platform) \n]
}
proc checkForEagle { channel } {
tputs $channel "---- checking for Eagle... "
if {[isEagle]} then {
#
# NOTE: We are running inside Eagle.
#
addConstraint eagle
#
# NOTE: We do not want to skip bugs or crashing
# issues for Tcl since we are not running
# in Tcl.
#
addConstraint tclBug
addConstraint tclCrash
#
# NOTE: Add the necessary constraints for each
# version of Tcl we know about.
#
foreach version [list 84 85 86] {
addConstraint [appendArgs tclBug $version]
addConstraint [appendArgs tclCrash $version]
}
tputs $channel yes\n
} else {
#
# NOTE: We are running inside Tcl.
#
addConstraint tcl
#
# NOTE: Each Tcl bug and crash constraint is set
# based on the exact Tcl version (i.e. not
# greater than or equal to).
#
if {[info exists ::tcl_version]} then {
#
# NOTE: For each Tcl version we know about,
# check it against the currently running
# Tcl version. If the two are not equal,
# add the test constraints that prevent
# skipping those tests that are buggy
# only for the particular version of Tcl.
#
foreach dotVersion [list 8.4 8.5 8.6] {
if {$::tcl_version ne $dotVersion} then {
set version [string map [list . ""] $dotVersion]
addConstraint [appendArgs tclBug $version]
addConstraint [appendArgs tclCrash $version]
}
}
}
#
# NOTE: We do not want to skip bugs or crashing
# issues for Eagle since we are not running
# in Eagle.
#
addConstraint eagleBug
addConstraint eagleCrash
tputs $channel no\n
}
}
proc checkForGaruda { channel } {
tputs $channel "---- checking for Garuda... "
if {[haveGaruda packageId]} then {
#
# NOTE: We are running with or via Garuda.
#
addConstraint garuda
tputs $channel [appendArgs "yes (" $packageId ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForShell { channel } {
tputs $channel "---- checking for shell... "
set name [file rootname [file tail [info nameofexecutable]]]
if {[isEagle]} then {
if {$name eq "EagleShell"} then {
#
# NOTE: We are running in Eagle via the EagleShell.
#
addConstraint shell
tputs $channel "yes (Eagle)\n"
#
# NOTE: We are done here, return now.
#
return
}
} else {
if {[string match tclsh* $name]} then {
#
# NOTE: We are running in Tcl via tclsh.
#
addConstraint shell
tputs $channel "yes (Tcl)\n"
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForDebug { channel } {
tputs $channel "---- checking for debug... "
if {[info exists ::tcl_platform(debug)] && $::tcl_platform(debug)} then {
addConstraint debug
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForVersion { channel } {
tputs $channel "---- checking for language version... "
if {[info exists ::tcl_version]} then {
#
# TODO: Cleanup the semantics for adding test
# constraints here.
#
if {$::tcl_version eq "8.4"} then {
#
# NOTE: Baseline reported language and feature
# version.
#
addConstraint tcl84
addConstraint tcl84OrHigher
addConstraint tcl84Feature
if {[isEagle]} then {
#
# NOTE: *EAGLE* We do want to include any
# tests that target "Tcl 8.5 or higher"
# features and/or "Tcl 8.6 or higher"
# features because they would not be in
# the test suite if we did not support
# that particular feature, regardless
# of the language version.
#
addConstraint tcl85Feature
addConstraint tcl86Feature
}
} elseif {$::tcl_version eq "8.5"} then {
#
# NOTE: Baseline reported language and feature
# version. Tcl 8.5 includes all the
# features from itself and Tcl 8.4.
#
addConstraint tcl85
addConstraint tcl84OrHigher
addConstraint tcl85OrHigher
addConstraint tcl84Feature
addConstraint tcl85Feature
if {[isEagle]} then {
#
# NOTE: *EAGLE* We do want to include any
# tests that target "Tcl 8.5 or higher"
# features and/or "Tcl 8.6 or higher"
# features because they would not be in
# the test suite if we did not support
# that particular feature, regardless
# of the language version.
#
addConstraint tcl86Feature
}
} elseif {$::tcl_version eq "8.6"} then {
#
# NOTE: Baseline reported language and feature
# version. Tcl 8.6 includes all the
# features from itself Tcl 8.4, and Tcl
# 8.5.
#
addConstraint tcl86
addConstraint tcl84OrHigher
addConstraint tcl85OrHigher
addConstraint tcl86OrHigher
addConstraint tcl84Feature
addConstraint tcl85Feature
addConstraint tcl86Feature
}
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 command.$name
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForFile { channel name {constraint ""} } {
tputs $channel [appendArgs "---- checking for file \"" $name \
"\"... "]
if {[file exists $name]} then {
#
# NOTE: Yes, it appears that it is available.
#
if {[string length $constraint] > 0} then {
addConstraint file_$constraint
} else {
addConstraint 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 file_$constraint
} else {
addConstraint 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 {$::tcl_platform(platform) eq "windows"} 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 {$::tcl_platform(platform) eq "windows"} 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 file_$constraint
} else {
addConstraint 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
#
# HACK: Needed by test "benchmark-1.22".
#
addConstraint compile.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 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... "
#
# NOTE: Is the interpreter TIP #285 ready?
#
catch {interp cancel} error
if {$error eq "eval canceled"} then {
addConstraint tip285
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTiming { channel threshold } {
tputs $channel "---- checking for precision timing... "
#
# NOTE: Are we allowed to do precision timing tests?
#
if {![info exists ::no(timing)]} then {
#
# NOTE: Attempt to block for exactly one second.
#
set start [expr {[clock clicks -milliseconds] & 0x7fffffff}]
after 1000; # wait for "exactly" one second.
set stop [expr {[clock clicks -milliseconds] & 0x7fffffff}]
#
# NOTE: Calculate the difference between the actual and expected
# number of milliseconds.
#
set difference [expr {abs($stop - $start - 1000)}]
#
# NOTE: Are we within the threshold specified by the caller?
#
if {$difference >= 0 && $difference <= $threshold} then {
addConstraint timing
tputs $channel [appendArgs "yes (0 <= " $difference " <= " \
$threshold " milliseconds)\n"]
} else {
tputs $channel [appendArgs "no (0 <= " $difference " > " \
$threshold " milliseconds)\n"]
}
} else {
tputs $channel no\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 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 checkForUserInteraction { channel } {
tputs $channel "---- checking for user interaction... "
#
# HACK: For now, do the exact same check as checkForInteractive; however,
# this is still useful as a separate constraint because it can be
# individually disabled in "prologue.eagle".
#
if {[info exists ::tcl_interactive] && $::tcl_interactive} then {
addConstraint userInteraction
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForNetwork { channel host timeout } {
tputs $channel [appendArgs \
"---- checking for network connectivity to host \"" $host "\"... "]
if {[isEagle]} then {
#
# BUGBUG: Tcl 8.4 does not like this expression (and Tcl tries to
# compile it even though it will only actually ever be
# evaluated in Eagle).
#
set expr {[llength [info commands uri]] > 0 && \
[catch {uri ping $host $timeout} response] == 0 && \
[lindex $response 0] in [list Success TimedOut] && \
[string is integer -strict [lindex $response 1]] && \
[lindex $response 1] <= $timeout}
#
# NOTE: Does it look like we are able to contact the network host?
#
if {[expr $expr]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint network_$host
tputs $channel [appendArgs "yes (" $response ")\n"]
} else {
tputs $channel no\n
}
} else {
#
# HACK: Running in Tcl, just assume we have network access.
#
addConstraint network_$host
tputs $channel yes\n
}
}
if {[isEagle]} then {
###########################################################################
############################ BEGIN Eagle ONLY #############################
###########################################################################
proc checkForSoftwareUpdateTrust { channel } {
tputs $channel "---- checking for software update trust... "
if {[llength [info commands uri]] > 0 && \
[catch {uri softwareupdates} result] == 0 && \
$result 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 checkForAdministrator { channel } {
tputs $channel "---- checking for administrator... "
if {[isAdministrator]} then {
addConstraint administrator; # running as full admin.
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForHost { channel } {
tputs $channel "---- checking for host... "
if {[set code [catch {host isopen} result]] == 0 && $result} then {
addConstraint hostIsOpen
tputs $channel open\n
} elseif {$code == 0} then {
tputs $channel closed\n
} else {
tlog $result; tputs $channel error\n]
}
}
proc checkForPrimaryThread { channel } {
tputs $channel "---- checking for primary thread... "
set threadId [object invoke Interpreter.GetActive ThreadId]
if {[info tid] == $threadId} then {
addConstraint primaryThread
tputs $channel [appendArgs "yes (" $threadId ")\n"]
} else {
tputs $channel [appendArgs "no (" $threadId ")\n"]
}
}
proc checkForRuntime { channel } {
tputs $channel "---- checking for runtime... "
#
# NOTE: Are we running inside Mono (regardless of operating system)?
#
if {[isMono]} then {
#
# NOTE: Yes, it appears that we are running inside Mono.
#
addConstraint mono; # running on Mono.
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : "Mono"}] \n]
} else {
#
# NOTE: No, it appears that we are not running inside Mono.
#
addConstraint dotNet; # running on .NET.
#
# NOTE: We do not want to skip Mono bugs on .NET.
#
addConstraint monoToDo; # running on .NET.
addConstraint monoBug; # running on .NET.
addConstraint monoCrash; # running on .NET.
tputs $channel [appendArgs [expr {[info exists \
::eagle_platform(runtime)] ? \
$::eagle_platform(runtime) : "Microsoft.NET"}] \n]
}
}
proc checkForImageRuntimeVersion { channel } {
tputs $channel "---- checking for image runtime version... "
if {[info exists ::eagle_platform(imageRuntimeVersion)] && \
[string length $::eagle_platform(imageRuntimeVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the version only.
#
set dotVersion [join [lrange [split \
$::eagle_platform(imageRuntimeVersion) .] 0 1] .]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list v "" . ""] $dotVersion]
#
# NOTE: Keep track of the specific image runtime version for usage in
# test constraints.
#
addConstraint imageRuntime$version
tputs $channel [appendArgs $::eagle_platform(imageRuntimeVersion) \
" " ( $dotVersion ) \n]
} else {
tputs $channel no\n
}
}
proc checkForRuntimeVersion { channel } {
tputs $channel "---- checking for runtime version... "
if {[info exists ::eagle_platform(runtimeVersion)] && \
[string length $::eagle_platform(runtimeVersion)] > 0} then {
#
# NOTE: Get the major and minor portions of the version only.
#
set dotVersion [join [lrange [split \
$::eagle_platform(runtimeVersion) .] 0 1] .]
#
# NOTE: Now create a version string for use in the constraint name
# (remove the periods).
#
set version [string map [list . ""] $dotVersion]
if {[isMono]} then {
if {[string length $version] > 0} then {
#
# NOTE: We are running on Mono. Keep track of the specific
# version for usage in test constraints.
#
addConstraint mono$version
}
if {[string length $dotVersion] > 0 && \
[regexp -- {^(\d+)\.(\d+)$} $dotVersion dummy \
majorVersion minorVersion]} then {
set monoVersions [list]
#
# NOTE: Check for any Mono version 2.x or higher.
#
if {$majorVersion >= 2} then {
#
# NOTE: Check for any Mono version higher than 2.0.
#
if {$majorVersion > 2 || $minorVersion > 0} then {
lappend monoVersions 20
}
#
# NOTE: Check for any Mono version higher than 2.2.
#
if {$majorVersion > 2 || $minorVersion > 2} then {
lappend monoVersions 22
}
#
# NOTE: Check for any Mono version higher than 2.4.
#
if {$majorVersion > 2 || $minorVersion > 4} then {
lappend monoVersions 24
}
#
# NOTE: Check for any Mono version higher than 2.6.
#
if {$majorVersion > 2 || $minorVersion > 6} then {
lappend monoVersions 26
}
#
# NOTE: Check for any Mono version higher than 2.8.
#
if {$majorVersion > 2 || $minorVersion > 8} then {
lappend monoVersions 28
}
#
# NOTE: Check for any Mono version higher than 2.10.
#
if {$majorVersion > 2 || $minorVersion > 10} then {
lappend monoVersions 210
}
}
#
# NOTE: Check for any Mono version 3.x or higher.
#
if {$majorVersion >= 3} then {
#
# NOTE: Check for any Mono version higher than 3.0.
#
if {$majorVersion > 3 || $minorVersion > 0} then {
lappend monoVersions 30
}
}
#
# NOTE: Add the necessary constraints for each version of Mono we
# should NOT skip bugs for.
#
foreach monoVersion $monoVersions {
addConstraint [appendArgs monoToDo $monoVersion]
addConstraint [appendArgs monoBug $monoVersion]
addConstraint [appendArgs monoCrash $monoVersion]
}
}
} else {
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 dotNet$version
}
#
# NOTE: We do not want to skip any Mono bugs on .NET. Add the
# necessary constraints for each version of Mono we know
# about.
#
foreach monoVersion [list 20 22 24 26 28 210 30] {
addConstraint [appendArgs monoToDo $monoVersion]
addConstraint [appendArgs monoBug $monoVersion]
addConstraint [appendArgs monoCrash $monoVersion]
}
}
tputs $channel [appendArgs $::eagle_platform(runtimeVersion) \
" " ( $dotVersion ) \n]
} else {
tputs $channel no\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(osBits)]} then {
#
# NOTE: Does the machine and number of bits match
# what the caller specified?
#
if {$::tcl_platform(machine) eq $machine && \
$::tcl_platform(osBits) eq $bits} then {
#
# NOTE: Yes, it matches.
#
addConstraint $machine.${bits}bit
set result yes
} else {
set result no
}
tputs $channel [appendArgs $result ", " $::tcl_platform(osBits) -bit \
" " $::tcl_platform(machine)\n]
} else {
tputs $channel "no, unknown\n"
}
}
proc checkForGarudaDll { channel } {
#
# NOTE: Check for the Garuda DLL of the same platform (i.e. machine
# type) as the native Tcl shell.
#
return [checkForFile $channel [file join $::base_path bin \
[machineToPlatform [getMachineForTclShell]] \
[appendArgs $::eagle_platform(configuration) Dll] \
[appendArgs Garuda [info sharedlibextension]]]]
}
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 culture.[string map [list - _] $culture]
tputs $channel [appendArgs $culture \n]
} else {
tputs $channel [appendArgs unknown \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 checkForCompileOption { channel option } {
tputs $channel [appendArgs "---- checking for compile option \"" \
$option "\"... "]
if {[info exists ::eagle_platform(compileOptions)] && \
[lsearch -exact -nocase $::eagle_platform(compileOptions) \
$option] != -1} then {
#
# NOTE: Yes, support for the compile option is present.
#
addConstraint compile.$option
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 runtime.$option
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForDynamicLoading { channel } {
tputs $channel "---- checking for dynamic loading... "
#
# NOTE: As far as we know, dynamic loading always works on Windows.
# On some Unix systems, dlopen does not work (e.g. because
# Mono is statically linked, etc).
#
if {$::tcl_platform(platform) eq "windows" || \
([llength [info commands library]] > 0 && \
[catch {library test}] == 0)} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint dynamic
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForWindowsForms { channel } {
tputs $channel "---- checking for Windows Forms... "
#
# HACK: When running on Windows, we do not need to do any other
# special checks here; however, on Unix (and Mac OS X?),
# we should check for the DISPLAY environment variable as
# some basic indication that the X server is available.
# This appears to be very necessary on Mono because it
# crashes after repeated failed attempts to create a
# Windows Form when the X server is unavailable (e.g. on
# OpenBSD).
#
if {$::tcl_platform(platform) eq "windows" || \
[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 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 string } {
tputs $channel "---- checking for database... "
#
# HACK: Disable database connectivity testing on Mono because
# it fails to timeout (unless special test suite hacks
# for Mono have been disabled by the user).
#
if {[info exists ::no(mono)] || ![isMono]} then {
#
# NOTE: Can we access the local database?
#
if {[catch {sql open $string} connection] == 0} then {
#
# NOTE: Yes, it appears that we can connect to the local database.
#
addConstraint sql
#
# NOTE: Cleanup the database connection we just opened.
#
sql close $connection
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
tputs $channel "disabled\n"
}
}
proc checkForAssembly { channel name } {
tputs $channel [appendArgs "---- checking for assembly \"" $name \
"\"... "]
#
# NOTE: Can the assembly be loaded?
#
if {[catch {object resolve $name} assembly] == 0} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint $name
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForObjectMember { channel object member } {
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.
#
addConstraint $object.[string trim $member *?]
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTclInstalls { channel } {
tputs $channel "---- checking for Tcl installs... "
#
# NOTE: Check for dynamically loadable Tcl libraries (for this
# architecture only).
#
if {[catch {tcl select -architecture} tcl] == 0} then {
#
# NOTE: Did we find one? Attempt to grab the index
# of the version field from the list.
#
set index [lsearch -exact $tcl version]
if {$index != -1} then {
#
# NOTE: The very next list index contains the value
# (i.e. like a Tcl 8.5+ dict).
#
set dotVersion [lindex $tcl [incr index]]
#
# NOTE: Do we know the version?
#
if {[string length $dotVersion] > 0 && \
[regexp -- {^\d+\.\d+$} $dotVersion]} then {
#
# NOTE: Yes, some version of Tcl is available.
#
addConstraint tclLibrary
#
# NOTE: Is the version 8.x or higher?
#
if {$dotVersion >= 8.6} then {
addConstraint tclLibrary86
} elseif {$dotVersion >= 8.5} then {
addConstraint tclLibrary85
} elseif {$dotVersion >= 8.4} then {
addConstraint tclLibrary84
}
tputs $channel [appendArgs $dotVersion \n]
#
# NOTE: We are done here, return now.
#
return
}
}
}
tputs $channel no\n
}
proc checkForTclReady { channel } {
tputs $channel "---- checking for Tcl readiness... "
if {[catch {tcl ready} result] == 0 && $result} then {
#
# NOTE: Yes, native Tcl is loaded and ready.
#
addConstraint tclReady
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForTclShell { channel } {
#
# HACK: We do not care about the machine type 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).
#
if {[catch {getMachineForTclShell} result] == 0 && \
$result ne "error"} then {
#
# NOTE: Yes, a native Tcl shell appears to be available.
#
addConstraint tclShell
tputs $channel "---- checking for Tcl shell... yes\n"
} else {
tputs $channel "---- checking for Tcl shell... 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 {$::tcl_platform(platform) eq "windows"} 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.
#
set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows Installer XML}
#
# NOTE: The versions of WiX that we support.
#
set versions [list 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.
#
set directory [file normalize [string trimright [object invoke \
Microsoft.Win32.Registry GetValue \
[appendArgs $key \\ $version] InstallRoot \
null] \\]]
#
# NOTE: Does the directory name look valid and
# does it actually exist?
#
if {[string length $directory] > 0} then {
#
# 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 registry
#
# NOTE: We found it, bail out now.
#
break
} else {
#
# NOTE: The file does not exist or is not properly
# versioned.
#
set directory ""
}
} else {
#
# NOTE: The directory does not exist.
#
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.
#
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 checkForManagedDebugger { channel } {
tputs $channel "---- checking for managed debugger... "
#
# NOTE: Is the managed debugger attached?
#
if {[object invoke System.Diagnostics.Debugger IsAttached]} then {
#
# NOTE: Yes, it appears that it is attached.
#
addConstraint managedDebugger
tputs $channel yes\n
} else {
tputs $channel no\n
}
}
proc checkForScriptDebugger { channel } {
tputs $channel "---- checking for script debugger... "
#
# NOTE: Is the script debugger available?
#
if {[catch {object invoke -flags +NonPublic Interpreter.GetActive \
Debugger} debugger] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $debugger] > 0} then {
object flags $debugger +NoDispose
}
if {[regexp -- {^Debugger#\d+$} $debugger]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint scriptDebugger
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
tputs $channel no\n
}
proc checkForScriptDebuggerInterpreter { channel } {
tputs $channel "---- checking for script debugger interpreter... "
#
# NOTE: Is the script debugger interpreter available?
#
if {[catch {object invoke -flags +NonPublic Interpreter.GetActive \
Debugger} debugger] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $debugger] > 0} then {
object flags $debugger +NoDispose
}
if {[regexp -- {^Debugger#\d+$} $debugger] && \
[catch {object invoke $debugger Interpreter} interp] == 0} then {
#
# NOTE: We do not own this, do not dispose it.
#
if {[string length $interp] > 0} then {
object flags $interp +NoDispose
}
if {[regexp -- {^Interpreter#\d+$} $interp]} then {
#
# NOTE: Yes, it appears that it is available.
#
addConstraint scriptDebuggerInterpreter
tputs $channel yes\n
#
# NOTE: We are done here, return now.
#
return
}
}
}
tputs $channel no\n
}
###########################################################################
############################# END Eagle ONLY ##############################
###########################################################################
} else {
###########################################################################
############################# BEGIN Tcl ONLY ##############################
###########################################################################
#
# NOTE: We need several of our test constraint related commands in the
# global namespace.
#
exportAndImportPackageCommands [namespace current] [list checkForPlatform \
checkForEagle checkForGaruda checkForShell checkForDebug \
checkForVersion checkForCommand checkForFile checkForNativeCode \
checkForTip127 checkForTip194 checkForTip241 checkForTip285 \
checkForPerformance checkForTiming checkForInteractive \
checkForUserInteraction checkForNetwork] false false
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: Provide the Eagle test constraints package to the interpreter.
#
package provide EagleTestConstraints \
[expr {[isEagle] ? [info engine PatchLevel] : 1.0}]
}