Index: Externals/Eagle/bin/Eagle.dll ================================================================== --- Externals/Eagle/bin/Eagle.dll +++ Externals/Eagle/bin/Eagle.dll cannot compute difference between binary files Index: Externals/Eagle/bin/EagleShell.exe ================================================================== --- Externals/Eagle/bin/EagleShell.exe +++ Externals/Eagle/bin/EagleShell.exe cannot compute difference between binary files Index: Externals/Eagle/bin/EagleShell32.exe ================================================================== --- Externals/Eagle/bin/EagleShell32.exe +++ Externals/Eagle/bin/EagleShell32.exe cannot compute difference between binary files Index: Externals/Eagle/bin/x64/Spilornis.dll ================================================================== --- Externals/Eagle/bin/x64/Spilornis.dll +++ Externals/Eagle/bin/x64/Spilornis.dll cannot compute difference between binary files Index: Externals/Eagle/bin/x86/Spilornis.dll ================================================================== --- Externals/Eagle/bin/x86/Spilornis.dll +++ Externals/Eagle/bin/x86/Spilornis.dll cannot compute difference between binary files Index: Externals/Eagle/lib/Eagle1.0/init.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/init.eagle +++ Externals/Eagle/lib/Eagle1.0/init.eagle @@ -101,10 +101,27 @@ # proc isMono {} { return [expr {[info exists ::eagle_platform(runtime)] && \ [string compare -nocase mono $::eagle_platform(runtime)] == 0}] } + + # + # NOTE: This procedure returns non-zero if the specified file names refer + # to the same file, using the most robust method available for the + # script engine and platform. + # + proc isSameFileName { fileName1 fileName2 } { + if {[isEagle]} then { + return [file same $fileName1 $fileName2] + } else { + if {[isWindows]} then { + return [string equal -nocase $fileName1 $fileName2] + } else { + return [string equal $fileName1 $fileName2] + } + } + } proc getEnvironmentVariable { name } { # # NOTE: This should work properly in both Tcl and Eagle. # @@ -916,22 +933,51 @@ # set platformOptions [expr { \ [info exists ::eagle_platform(compileOptions)] ? \ $::eagle_platform(compileOptions) : [list]}] - if {[llength $platformOptions] > 0} then { + # + # NOTE: Permit extra C# compiler options to be passed via the global + # array element "csharpOptions", if it exists. + # + set csharpOptions [expr { \ + [info exists ::eagle_platform(csharpOptions)] ? \ + $::eagle_platform(csharpOptions) : [list]}] + + if {[llength $platformOptions] > 0 || \ + [llength $csharpOptions] > 0} then { # # NOTE: Grab the existing compiler options, if any. # set compilerOptions [$parameters CompilerOptions] if {"DEBUG" in $platformOptions} then { - append compilerOptions " /define:DEBUG" + if {[string length $compilerOptions] > 0} then { + append compilerOptions " " + } + + append compilerOptions /define:DEBUG } if {"TRACE" in $platformOptions} then { - append compilerOptions " /define:TRACE" + if {[string length $compilerOptions] > 0} then { + append compilerOptions " " + } + + append compilerOptions /define:TRACE + } + + # + # NOTE: Append the configured extra C# compiler options configured + # via the global array element "csharpOptions", if any. + # + foreach csharpOption $csharpOptions { + if {[string length $compilerOptions] > 0} then { + append compilerOptions " " + } + + append compilerOptions $csharpOption } # # NOTE: Reset the compiler options to the pre-existing ones plus the # extra defines we may have added (above). @@ -1812,25 +1858,26 @@ if {$length > $maxLength} { set maxLength $length } } + set stringMap [list \b " " \t " " \r \xB6 \n \xB6] set maxLength [expr {$maxLength + [string length $a] + 2}] set hostLength [lindex [getHostSize] 0] set valueLength [expr {$hostLength - $maxLength - 5}]; # " ... " foreach name $names { # # NOTE: Format the array element name for display. # - set nameString [appendArgs $a ( $name )] + set nameString [string map $stringMap [appendArgs $a ( $name )]] # # NOTE: If the value by itself is too long to fit on one host line, # just truncate and ellipsis it. # - set valueString $array($name) + set valueString [string map $stringMap $array($name)] if {[string length $valueString] > $valueLength} then { set valueString [appendArgs [string range $valueString 0 \ [expr {$valueLength - 4}]] " ..."] } @@ -1966,11 +2013,11 @@ proc findDirectories { pattern } { # # NOTE: Block non-Windows platforms since this is Windows specific. # - if {$::tcl_platform(platform) ne "windows"} then { + if {![isWindows]} then { error "not supported on this operating system" } # # NOTE: This should work properly in Eagle only. @@ -2014,11 +2061,11 @@ proc findFiles { pattern } { # # NOTE: Block non-Windows platforms since this is Windows specific. # - if {$::tcl_platform(platform) ne "windows"} then { + if {![isWindows]} then { error "not supported on this operating system" } # # NOTE: This should work properly in Eagle only. @@ -2062,11 +2109,11 @@ proc findFilesRecursive { pattern } { # # NOTE: Block non-Windows platforms since this is Windows specific. # - if {$::tcl_platform(platform) ne "windows"} then { + if {![isWindows]} then { error "not supported on this operating system" } # # NOTE: This should work properly in Eagle only. @@ -2169,11 +2216,11 @@ proc findFilesRecursive { pattern } { # # NOTE: Block non-Windows platforms since this is Windows specific. # - if {$::tcl_platform(platform) ne "windows"} then { + if {![isWindows]} then { error "not supported on this operating system" } # # NOTE: This should work properly in Tcl only. @@ -2260,11 +2307,11 @@ # # NOTE: Exports the necessary commands from this package and import them # into the global namespace. # exportAndImportPackageCommands [namespace current] [list \ - isEagle isWindows haveGaruda isTclThread isMono \ + isEagle isWindows haveGaruda isTclThread isMono isSameFileName \ getEnvironmentVariable combineFlags getCompileInfo getPlatformInfo \ getPluginPath appendArgs lappendArgs getDictionaryValue \ getColumnValue getRowColumnValue tqputs tqlog readFile \ readSharedFile writeFile appendFile appendLogFile appendSharedFile \ appendSharedLogFile readAsciiFile writeAsciiFile readUnicodeFile \ Index: Externals/Eagle/lib/Eagle1.0/test.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/test.eagle +++ Externals/Eagle/lib/Eagle1.0/test.eagle @@ -485,31 +485,70 @@ # TODO: Add more support for standard tcltest options here. # set options [list \ -breakOnLeak -configuration -constraints -exitOnComplete -file \ -logFile -machine -match -no -notFile -platform -postTest -preTest \ - -randomOrder -skip -startFile -stopFile -stopOnFailure -suffix \ - -suite -tclsh -threshold] + -randomOrder -skip -startFile -stopFile -stopOnFailure -stopOnLeak \ + -suffix -suite -tclsh -threshold] - foreach {name value} $args { + set length [llength $args] + + for {set index 0} {$index < $length} {incr index} { + # + # NOTE: Grab the current list element, which should be the name of + # the test option. + # + set name [lindex $args $index] + # # NOTE: Use the [tqputs] command here just in case the test log file # has not been setup yet (i.e. by default, this procedure is # almost always called by the test prologue file prior to the # test log file having been setup and we do not want to just # lose this output). # if {[lsearch -exact $options $name] != -1} then { - set array($name) $value + # + # NOTE: Is there another list element available for the value? If + # not, this is not a valid test option. + # + if {$index + 1 < $length} then { + incr index; set value [lindex $args $index] - tqputs $::test_channel [appendArgs \ - "---- overrode test option \"" $name "\" with value \"" \ - $value \"\n] + set array($name) $value + + tqputs $::test_channel [appendArgs \ + "---- overrode test option \"" $name "\" with value \"" \ + $value \"\n] + } else { + tqputs $::test_channel [appendArgs \ + "---- no value for test option \"" $name "\", ignored\n"] + } + } elseif {[string index $name 0] eq "-"} then { + # + # NOTE: Is there another list element available for the value? If + # not, it does not conform to the standard command line name + # and value pattern. + # + if {$index + 1 < $length} then { + incr index; set value [lindex $args $index] + + tqputs $::test_channel [appendArgs \ + "---- unknown test option \"" $name "\" with value \"" \ + $value "\" ignored\n"] + } else { + tqputs $::test_channel [appendArgs \ + "---- no value for unknown test option \"" $name \ + "\" ignored\n"] + } } else { + # + # NOTE: This is not an option of *any* kind that we know about. + # Ignore it and issue a warning. + # tqputs $::test_channel [appendArgs \ - "---- unknown test option \"" $name "\" with value \"" \ - $value "\" ignored\n"] + "---- unknown argument \"" $name "\" ignored\n"] } } # # NOTE: Now, attempt to flush the test log queue, if available. @@ -801,14 +840,82 @@ proc getTestLogId {} { return [expr {[info exists ::test_log_id] ? \ [append result . $::test_log_id] : ""}] } + + proc getDefaultTestLog {} { + return [file join [getTemporaryPath] [appendArgs \ + [file tail [info nameofexecutable]] [getTestLogId] \ + .test. [pid] .log]] + } proc getTestLog {} { return [expr {[info exists ::test_log] ? $::test_log : ""}] } + + proc getLastTestLog {} { + # + # NOTE: Use the configured log file name -OR- what the configured + # log file name would be, by default, if it actually existed. + # + if {[info exists ::test_log]} then { + set logFileName $::test_log + } else { + set logFileName [getDefaultTestLog] + } + + set logFileName [file normalize $logFileName] + set logTime [expr {[file exists $logFileName] ? \ + [file mtime $logFileName] : 0}] + + # + # NOTE: Make the log file name into a pattern we can use to find + # the related log files. + # + if {[regsub -- {\.\d+\.} $logFileName {.*.} pattern]} then { + set lastLogFile [list] + + foreach fileName [findFiles $pattern] { + # + # NOTE: Skip the current test log file, if found. + # + if {[isSameFileName $fileName $logFileName]} then { + continue + } + + # + # NOTE: When was this log file last modified? + # + set time [file mtime $fileName] + + # + # NOTE: Check if there has been no log file seen -OR- this + # log file has the latest modified time seen. + # + if {[llength $lastLogFile] == 0 || \ + $time > [lindex $lastLogFile 0]} then { + # + # NOTE: This is now the latest log file seen. + # + set lastLogFile [list $time $fileName] + } + } + + # + # NOTE: Either return the last log file seen, if any -OR- the + # configured log file, if it actually exists. + # + if {[llength $lastLogFile] > 0} then { + return [lindex $lastLogFile 1] + } elseif {$logTime != 0} then { + return $logFileName + } + } + + return "" + } proc getTestSuite {} { # # NOTE: Determine the effective test suite name and return it. If the # test suite name cannot be determined, return the default based @@ -1080,10 +1187,16 @@ proc isStopOnFailure {} { return [expr {[info exists ::test_stop_on_failure] && \ [string is boolean -strict $::test_stop_on_failure] && \ $::test_stop_on_failure}] } + + proc isStopOnLeak {} { + return [expr {[info exists ::test_stop_on_leak] && \ + [string is boolean -strict $::test_stop_on_leak] && \ + $::test_stop_on_leak}] + } proc isExitOnComplete {} { return [expr {[info exists ::test_exit_on_complete] && \ [string is boolean -strict $::test_exit_on_complete] && \ $::test_exit_on_complete}] @@ -1302,10 +1415,11 @@ # # NOTE: Record counts of all object types that we track. # upvar 1 $varName array + set array(uncounted,$index) [list] set array(time,$index) [clock seconds] set array(afters,$index) [llength [after info]] set array(variables,$index) [llength [info globals]] set array(commands,$index) [llength [info commands]] set array(procedures,$index) [llength [info procs]] @@ -1315,10 +1429,17 @@ set array(channels,$index) [llength [file channels]] set array(aliases,$index) [llength [interp aliases]] set array(interpreters,$index) [llength [interp slaves]] set array(environment,$index) [llength [array names env]] + # + # NOTE: These native resource types cannot be positively checked + # for leaks (i.e. because the "leak" may be from an external + # process). + # + lappend array(uncounted,$index) temporaryFiles + if {[isEagle]} then { set array(scopes,$index) [llength [scope list]] set array(assemblies,$index) [llength [object assemblies]] set array(processes,$index) [llength [getProcesses ""]] set array(objects,$index) [llength [info objects]] @@ -1325,10 +1446,17 @@ set array(objectCallbacks,$index) [llength [info callbacks]] set array(objectTypes,$index) [llength [object types]] set array(objectInterfaces,$index) [llength [object interfaces]] set array(objectNamespaces,$index) [llength [object namespaces]] + # + # NOTE: These managed resource types cannot be positively checked + # for leaks (i.e. because the "leak" may be from an external + # process). + # + lappend array(uncounted,$index) assemblies processes + # # NOTE: Support for some of all of these entity types may not be # present in the interpreter, initialize all these counts # to zero and then try to query each one individually below # wrapped in a catch. @@ -1378,11 +1506,11 @@ # set count 0; upvar 1 $statsVarName array foreach statistic $statistics { if {$array($statistic,after) > $array($statistic,before)} then { - incr count; lappend array(statistics,leaked) $statistic + lappend array(statistics,leaked) $statistic tputs $channel [appendArgs "==== \"" $fileName "\" LEAKED " \ $statistic \n] if {[info exists array($statistic,before,list)]} then { @@ -1392,10 +1520,22 @@ if {[info exists array($statistic,after,list)]} then { tputs $channel [appendArgs "---- " $statistic " AFTER: " \ [formatList $array($statistic,after,list)] \n] } + + if {[info exists array(uncounted,before)] && \ + [lsearch -exact $array(uncounted,before) $statistic] != -1} then { + continue + } + + if {[info exists array(uncounted,after)] && \ + [lsearch -exact $array(uncounted,after) $statistic] != -1} then { + continue + } + + incr count } } # # NOTE: Make sure this file name is recorded in the list of file names with @@ -1407,15 +1547,22 @@ [lsearch -exact $fileNames [file tail $fileName]] == -1} then { lappend fileNames [file tail $fileName] } # - # NOTE: If we are supposed to break into the debugger whenever a leak is - # detected, do it now. + # NOTE: If we are supposed to stop or break into the debugger whenever + # a leak is detected, do it now. # - if {$count > 0 && [isBreakOnLeak]} then { - testDebugBreak + if {$count > 0} then { + if {[isStopOnLeak]} then { + tresult Error "OVERALL RESULT: STOP-ON-LEAK\n" + + unset -nocomplain ::test_suite_running + error ""; # no message + } elseif {[isBreakOnLeak]} then { + testDebugBreak + } } } proc formatList { list {default ""} {columns 1} } { if {[catch { @@ -1496,13 +1643,18 @@ # to match an element against a list of patterns. # set command [list string match] if {$noCase} then {lappend command -nocase} - for {set index 0} {$index < [llength $patterns]} {incr index} { + set length [llength $patterns] + + for {set index 0} {$index < $length} {incr index} { set pattern [lindex $patterns $index] - if {[eval $command [list $pattern] [list $element]]} then {return $index} + + if {[eval $command [list $pattern] [list $element]]} then { + return $index + } } return -1 } @@ -2479,11 +2631,11 @@ } finally { interp bgerror {} $bgerror } } - proc testExecTclScript { script {shell ""} } { + proc testExecTclScript { script {shell ""} {verbose false} } { try { # # NOTE: Get a temporary file name for the script we are going to # use to query the machine type for the native Tcl shell. # @@ -2511,11 +2663,11 @@ } else { # # NOTE: We cannot execute the native Tcl shell because one # has not been specified, nor configured. # - return error + return [expr {$verbose ? "::test_tclsh missing" : "error"}] } } # # NOTE: Evaluate the script using the native Tcl shell, trim the @@ -2532,11 +2684,11 @@ } else { # # NOTE: We could not execute the native Tcl shell (perhaps one # is not available?). # - return error + return [expr {$verbose ? [appendArgs "error: " $result] : "error"}] } } finally { # # NOTE: Did we create a temporary file? # @@ -2579,10 +2731,22 @@ proc getTkVersionForTclShell { {shell ""} } { return [testExecTclScript { puts -nonewline stdout [package require Tk]; exit } $shell] } + + proc evalWithTclShell { script {raw false} {shell ""} {verbose false} } { + return [testExecTclScript [string map \ + [list %script% $script %raw% $raw] { + if {%raw%} then { + set code [catch {%script%} result] + puts -nonewline stdout [list $code $result] + } else { + puts -nonewline stdout [eval {%script%}] + } + }] $shell $verbose] + } proc getGarudaDll { {machine ""} } { # # NOTE: Get the Garuda DLL of the same platform (i.e. machine type) # as the native Tcl shell. @@ -2865,20 +3029,21 @@ tputs tlog getSoftwareRegistryKey haveConstraint addConstraint \ haveOrAddConstraint getConstraints removeConstraint fixConstraints \ calculateBogoCops calculateRelativePerformance formatTimeStamp \ formatElapsedTime sourceIfValid processTestArguments \ getTclShellFileName getTemporaryPath getFiles getTestFiles \ - getTestRunId getTestLogId getTestLog getTestSuite getTestMachine \ - getTestPlatform getTestConfiguration getTestSuffix testExec \ - testClrExec execTestShell isRandomOrder isBreakOnLeak isStopOnFailure \ - isExitOnComplete returnInfoScript runTestPrologue runTestEpilogue \ - hookPuts unhookPuts runTest testDebugBreak testArrayGet testShim \ - tsource recordTestStatistics reportTestStatistics formatList \ - formatListAsDict pathToRegexp inverseLsearchGlob \ - removePathFromFileNames formatDecimal clearTestPercent \ - reportTestPercent runAllTests isTestSuiteRunning configureTcltest \ - machineToPlatform getPassPercentage getSkipPercentage] false false + getTestRunId getTestLogId getDefaultTestLog getTestLog getLastTestLog \ + getTestSuite getTestMachine getTestPlatform getTestConfiguration \ + getTestSuffix testExec testClrExec execTestShell isRandomOrder \ + isBreakOnLeak isStopOnFailure isStopOnLeak isExitOnComplete \ + returnInfoScript runTestPrologue runTestEpilogue hookPuts unhookPuts \ + runTest testDebugBreak testArrayGet testShim tsource \ + recordTestStatistics reportTestStatistics formatList formatListAsDict \ + pathToRegexp inverseLsearchGlob removePathFromFileNames formatDecimal \ + clearTestPercent reportTestPercent runAllTests isTestSuiteRunning \ + configureTcltest machineToPlatform getPassPercentage \ + getSkipPercentage] false false ########################################################################### ############################## END Tcl ONLY ############################### ########################################################################### } Index: Externals/Eagle/lib/Test1.0/constraints.eagle ================================================================== --- Externals/Eagle/lib/Test1.0/constraints.eagle +++ Externals/Eagle/lib/Test1.0/constraints.eagle @@ -246,28 +246,31 @@ if {![isEagle]} then { # # BUGFIX: We do not normally want to skip any Mono bugs in native Tcl. # if {![info exists ::no(runtimeVersion)]} then { - set constraints [list monoToDo monoBug monoCrash] - # # NOTE: Add the necessary constraints for each version of Mono that # we know about. # foreach monoVersion [getKnownMonoVersions] { set constraintVersion [join $monoVersion ""] addConstraint [appendArgs monoToDo $constraintVersion] + addConstraint [appendArgs monoToDo $constraintVersion Only] addConstraint [appendArgs monoBug $constraintVersion] + addConstraint [appendArgs monoBug $constraintVersion Only] addConstraint [appendArgs monoCrash $constraintVersion] + addConstraint [appendArgs monoCrash $constraintVersion Only] } # # NOTE: Also add just the generic Mono constraints that do not have # a trailing version. # + set constraints [list monoToDo monoBug monoCrash] + foreach constraint $constraints { addConstraint $constraint } } } @@ -769,12 +772,14 @@ # # NOTE: Baseline reported language and feature # version. # addConstraint tcl84 - addConstraint tcl84OrHigher addConstraint tcl84Feature + addConstraint tcl84OrLower + addConstraint tcl84OrHigher + addConstraint tcl85OrLower if {[isEagle]} then { # # NOTE: *EAGLE* We do want to include any # tests that target "Tcl 8.5 or higher" @@ -791,15 +796,16 @@ # # NOTE: Baseline reported language and feature # version. Tcl 8.5 includes all the # features from itself and Tcl 8.4. # - addConstraint tcl85 + addConstraint tcl84Feature addConstraint tcl84OrHigher - addConstraint tcl85OrHigher - addConstraint tcl84Feature + addConstraint tcl85 addConstraint tcl85Feature + addConstraint tcl85OrLower + addConstraint tcl85OrHigher if {[isEagle]} then { # # NOTE: *EAGLE* We do want to include any # tests that target "Tcl 8.5 or higher" @@ -816,17 +822,18 @@ # 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 tcl84Feature addConstraint tcl84OrHigher + addConstraint tcl85Feature addConstraint tcl85OrHigher - addConstraint tcl86OrHigher - addConstraint tcl84Feature - addConstraint tcl85Feature + addConstraint tcl86 addConstraint tcl86Feature + addConstraint tcl86OrLower + addConstraint tcl86OrHigher } tputs $channel [appendArgs $::tcl_version \n] } else { tputs $channel no\n @@ -850,11 +857,11 @@ } else { tputs $channel no\n } } - proc checkForNamespaces { channel } { + proc checkForNamespaces { channel quiet } { tputs $channel "---- checking for namespace support... " if {[isEagle]} then { # # NOTE: Check if namespace support was compiled into the core library @@ -889,11 +896,11 @@ # # NOTE: Check if namespace support was compiled into the core # library (i.e. is this beta 30 or later). # - if {$available} then { + 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. # @@ -914,21 +921,21 @@ tputs $channel enabled\n } } - proc checkForTestExec { channel } { + 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 {[info exists ::no(exec)]} then { + if {!$quiet && [info exists ::no(exec)]} then { tputs $channel \ "==== WARNING: running with the \"testExec\" procedure disabled\n" } } else { tputs $channel no\n @@ -1252,10 +1259,25 @@ tputs $channel yes\n } else { tputs $channel no\n } } + + proc checkForTip429 { channel } { + tputs $channel "---- checking for TIP #429... " + + # + # NOTE: Is the interpreter TIP #429 ready? + # + if {[catch {string cat}] == 0} then { + addConstraint tip429 + + tputs $channel yes\n + } else { + tputs $channel no\n + } + } proc checkForTiming { channel threshold {constraint ""} {tries 1} {delay 1000} {average false} {asynchronous false} } { tputs $channel [appendArgs \ @@ -1395,10 +1417,25 @@ } } 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... " # @@ -2037,10 +2074,39 @@ addConstraint [appendArgs mono $constraintVersion OrHigher] addConstraint [appendArgs monoToDo $constraintVersion] addConstraint [appendArgs monoBug $constraintVersion] addConstraint [appendArgs monoCrash $constraintVersion] } + + # + # NOTE: Check all known versions of Mono for an exact match with + # the currently running one. + # + foreach monoVersion [getKnownMonoVersions] { + # + # NOTE: Check if Mono major/minor version is exactly the one + # we are currently processing. + # + set constraintVersion [join $monoVersion ""] + + if {[lindex $monoVersion 0] == $majorVersion && \ + [lindex $monoVersion 1] == $minorVersion} then { + # + # NOTE: Add test constraints that only apply to this exact + # version of Mono. + # + addConstraint [appendArgs mono $constraintVersion Only] + } else { + # + # NOTE: Add test constraints that apply to all versions of + # Mono except this exact version. + # + addConstraint [appendArgs monoToDo $constraintVersion Only] + addConstraint [appendArgs monoBug $constraintVersion Only] + addConstraint [appendArgs monoCrash $constraintVersion Only] + } + } } } else { # # NOTE: If the runtime version was found, add a test constraint # for it now. @@ -2061,12 +2127,15 @@ # foreach monoVersion [getKnownMonoVersions] { set constraintVersion [join $monoVersion ""] addConstraint [appendArgs monoToDo $constraintVersion] + addConstraint [appendArgs monoToDo $constraintVersion Only] addConstraint [appendArgs monoBug $constraintVersion] + addConstraint [appendArgs monoBug $constraintVersion Only] addConstraint [appendArgs monoCrash $constraintVersion] + addConstraint [appendArgs monoCrash $constraintVersion Only] } } tputs $channel [appendArgs $::eagle_platform(runtimeVersion) \ " " ( $dotVersion ) \n] @@ -2183,23 +2252,30 @@ } else { tputs $channel unknown\n } } - proc checkForQuiet { channel } { - tputs $channel "---- checking for quiet... " + proc checkForQuiet { channel quiet } { + if {!$quiet} then { + tputs $channel "---- checking for quiet... " + } - if {[catch {object invoke Interpreter.GetActive Quiet} quiet] == 0 && \ - $quiet} then { + if {[catch { + object invoke Interpreter.GetActive Quiet + } isQuiet] == 0 && $isQuiet} then { # # NOTE: Yes, quiet mode is enabled. # addConstraint quiet - tputs $channel yes\n + if {!$quiet} then { + tputs $channel yes\n + } } else { - tputs $channel no\n + if {!$quiet} then { + tputs $channel no\n + } } } proc checkForReferenceCountTracking { channel } { tputs $channel "---- checking for object reference count tracking... " @@ -3118,15 +3194,15 @@ checkForShell checkForDebug checkForTk checkForVersion \ checkForCommand checkForNamespaces checkForTestExec \ checkForTestMachine checkForTestPlatform checkForTestConfiguration \ checkForTestSuffix checkForFile checkForPathFile checkForNativeCode \ checkForTip127 checkForTip194 checkForTip207 checkForTip241 \ - checkForTip285 checkForTip405 checkForTip426 checkForTiming \ - checkForPerformance checkForBigLists checkForStackIntensive \ - checkForInteractive checkForInteractiveCommand \ - checkForUserInteraction checkForNetwork checkForCompileOption \ - checkForKnownCompileOptions] false false + checkForTip285 checkForTip405 checkForTip426 checkForTip429 \ + checkForTiming checkForPerformance checkForBigLists \ + checkForMemoryIntensive checkForStackIntensive checkForInteractive \ + checkForInteractiveCommand checkForUserInteraction checkForNetwork \ + checkForCompileOption checkForKnownCompileOptions] false false ########################################################################### ############################## END Tcl ONLY ############################### ########################################################################### } Index: Externals/Eagle/lib/Test1.0/prologue.eagle ================================================================== --- Externals/Eagle/lib/Test1.0/prologue.eagle +++ Externals/Eagle/lib/Test1.0/prologue.eagle @@ -91,10 +91,24 @@ unset pkg_dir } ############################################################################# + # + # NOTE: Set the location of the Eagle main strong name keys directory, + # if necessary. + # + if {![info exists key_path]} then { + # + # NOTE: Normally, there should be a "Keys" sub-directory just within + # the base directory. + # + set key_path [file join $base_path Keys] + } + + ############################################################################# + # # NOTE: Set the executable file name for the process, if # necessary. # if {![info exists bin_file]} then { @@ -284,10 +298,11 @@ set test_flags(-logFile) ""; # default to using standard log file naming. set test_flags(-threshold) ""; # default to requiring all tests to pass. set test_flags(-randomOrder) ""; # default to deterministic order. set test_flags(-breakOnLeak) ""; # default to continue on leak. set test_flags(-stopOnFailure) ""; # default to continue on failure. + set test_flags(-stopOnLeak) ""; # default to continue on leak. set test_flags(-exitOnComplete) ""; # default to not exit after complete. set test_flags(-preTest) ""; # default to not evaluating anything. set test_flags(-postTest) ""; # default to not evaluating anything. set test_flags(-tclsh) ""; # Tcl shell, default to empty. @@ -352,10 +367,19 @@ # NOTE: Set the test stop-on-failure flag to the one provided by the # command line. # set test_stop_on_failure $test_flags(-stopOnFailure) } + + if {[info exists test_flags(-stopOnLeak)] && \ + [string is boolean -strict $test_flags(-stopOnLeak)]} then { + # + # NOTE: Set the test stop-on-leak flag to the one provided by the + # command line. + # + set test_stop_on_leak $test_flags(-stopOnLeak) + } if {[info exists test_flags(-exitOnComplete)] && \ [string is boolean -strict $test_flags(-exitOnComplete)]} then { # # NOTE: Set the test exit-on-complete flag to the one provided by the @@ -416,14 +440,37 @@ if {![info exists no(logFileName)]} then { # # NOTE: Set the log to use for test output, if necessary. # if {![info exists test_log]} then { - set test_log [file join [getTemporaryPath] [appendArgs [file tail [info \ - nameofexecutable]] [getTestLogId] .test. [pid] .log]] + set test_log [getDefaultTestLog] } } + + ############################################################################# + + # + # NOTE: *SPECIAL* This test constraint must be checked first as it can + # determine if subsequent ones will emit warnings. This is only + # applicable to Eagle. + # + if {[isEagle]} then { + # + # NOTE: Has quiet testing support been disabled? + # + if {![info exists no(preQuiet)]} then { + # + # NOTE: There are checks for the "quiet" test constraint prior to + # the real test constraints being initialized. Prepare for + # those checks now. This will have to be repeated later, + # after the real test constraints are initialized. + # + checkForQuiet $test_channel true + } + } + + ############################################################################# # # NOTE: Has native Tcl shell detection and use been disabled? # if {![info exists no(tclsh)]} then { @@ -451,11 +498,12 @@ ![info exists no(getTclShellFileName)]} then { # # NOTE: Attempt to automatically select the native Tcl shell # to use. # - if {![info exists no(warningForTclShell)]} then { + if {![info exists no(warningForTclShell)] && \ + ![haveConstraint quiet]} then { tputs $test_channel \ "==== WARNING: attempting automatic Tcl shell selection...\n" } set test_tclsh [getTclShellFileName true] @@ -477,11 +525,12 @@ # the interpreter and issue warnings if any are found. The warning # may be used to explain subsequent test failures due to the extra # plugins being loaded (i.e. there are some tests are sensitive to # having "unexpected" plugins loaded). # - if {[isEagle] && ![info exists no(warningForPlugin)]} then { + if {[isEagle] && ![info exists no(warningForPlugin)] && \ + ![haveConstraint quiet]} then { foreach loaded [info loaded] { # # HACK: This code assumes that all plugins in the "Eagle._Plugins" # namespace belong to the Eagle core library itself. # @@ -581,48 +630,11 @@ tputs $test_channel [appendArgs "---- test suffix: " \ [expr {[info exists test_suffix] ? \ $test_suffix : ""}] \n] - if {[isEagle] && ![info exists no(warningForStrongName)]} then { - catch {info engine PublicKeyToken} publicKeyToken - - if {[string length $publicKeyToken] == 0} then { - # - # NOTE: The Eagle core library is not strong name signed. This is 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. - # - tputs $test_channel \ - "==== WARNING: running without any strong name signature...\n" - } else { - # - # BUGBUG: Tcl 8.4 does not like this expression because it contains the - # "ni" operator (and Tcl tries to compile it even though it will - # only actually ever 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. - # - tputs $test_channel [appendArgs \ - "==== WARNING: running without official strong name signature: " \ - $publicKeyToken \n] - } - - unset expr - } - - unset publicKeyToken - + if {[isEagle]} then { tputs $test_channel [appendArgs "---- original command line: " \ [info cmdline] \n] tputs $test_channel [appendArgs "---- threadId: " \ [info tid] \n] @@ -695,10 +707,15 @@ tputs $test_channel [appendArgs "---- stop on failure: " \ [expr {[info exists test_stop_on_failure] && \ [string is boolean -strict $test_stop_on_failure] ? \ $test_stop_on_failure : ""}] \n] + + tputs $test_channel [appendArgs "---- stop on leak: " \ + [expr {[info exists test_stop_on_leak] && \ + [string is boolean -strict $test_stop_on_leak] ? \ + $test_stop_on_leak : ""}] \n] tputs $test_channel [appendArgs "---- exit on complete: " \ [expr {[info exists test_exit_on_complete] && \ [string is boolean -strict $test_exit_on_complete] ? \ $test_exit_on_complete : ""}] \n] @@ -743,10 +760,13 @@ [expr {[info exists path] && [string length $path] > 0 ? \ [appendArgs \" $path \"] : ""}] \n] tputs $test_channel [appendArgs "---- base path: \"" \ $base_path \"\n] + + tputs $test_channel [appendArgs "---- key path: \"" \ + $key_path \"\n] tputs $test_channel [appendArgs "---- root path: \"" \ $root_path \"\n] tputs $test_channel [appendArgs "---- binary path: \"" \ @@ -776,10 +796,14 @@ # # NOTE: Initialize the Eagle test constraints. # if {[isEagle]} then { + # + # NOTE: *WARNING* This has the effect of removing test constraints + # added prior to this point. + # initializeTests; configureTcltest [list] [list] [list] [list] false # # NOTE: If the "no(mono)" variable is set (to anything) then any # special test suite hacks for Mono will be disabled. This @@ -794,10 +818,94 @@ ######################### BEGIN Eagle Constraints ######################### ########################################################################### tputs $test_channel \ "---- start of Eagle specific test constraints...\n" + + # + # NOTE: *WARNING* Has quiet testing support been disabled? + # Please do not move this "quietness" test constraint + # check as subsequent test constraints may rely on it + # when determining if a warning should be emitted. + # + if {![info exists no(quiet)]} then { + # + # NOTE: For tests "basic-1.36", "benchmark-1.*", "debug-1.3", + # "debug-1.4", "glob-99.*", "object-10.*", "perf-2.2", + # and various other places within the test suite code + # itself. + # + checkForQuiet $test_channel false + } + + # + # NOTE: Has strong name key detection been disabled? + # + if {![info exists no(strongNameKey)]} then { + catch {info engine PublicKeyToken} publicKeyToken + + if {[string length $publicKeyToken] == 0} then { + # + # 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 + + if {![info exists no(warningForStrongNameKey)] && \ + ![haveConstraint quiet]} then { + tputs $test_channel \ + "==== WARNING: no Eagle strong name signature detected...\n" + } + } else { + # + # NOTE: Add a test constraint for this specific strong name key. + # + addConstraint [appendArgs strongName. $publicKeyToken] + + # + # 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 + + if {![info exists no(warningForStrongNameKey)] && \ + ![haveConstraint quiet]} then { + tputs $test_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 $test_channel [appendArgs \ + "---- official Eagle strong name signature detected: " \ + $publicKeyToken \n] + } + + unset expr + } + + unset publicKeyToken + } # # NOTE: Has administrator detection support been disabled? We do # this check [nearly] first as it may [eventually] be used # to help determine if other constraints should be skipped. @@ -1013,21 +1121,10 @@ # if {![info exists no(assemblySymbols)]} then { checkForSymbols $test_channel [lindex [info assembly] end] } - # - # NOTE: Has quiet testing support been disabled? - # - if {![info exists no(quiet)]} then { - # - # NOTE: For tests "basic-1.36", "debug-1.3", "debug-1.4", "object-10.*", - # and "perf-2.2". - # - checkForQuiet $test_channel - } - # # NOTE: Has object handle reference count tracking support been disabled # (at compile-time)? # if {![info exists no(refCount)]} then { @@ -1516,10 +1613,28 @@ checkForObjectMember $test_channel Eagle._Tests.Default \ *TestUnsetVariableLinks* } + # + # NOTE: Has system array variable testing support been disabled? + # + if {![info exists no(testSystemArrayVariables)]} then { + # + # NOTE: For tests "basic-1.62", "basic-1.63", "basic-1.64", + # and "basic-1.65". + # + checkForObjectMember $test_channel Eagle._Tests.Default \ + *TestIntPtrChangeTypeCallback* + + checkForObjectMember $test_channel Eagle._Tests.Default \ + *TestSetVariableSystemArray* + + checkForObjectMember $test_channel Eagle._Tests.Default \ + *TestUnsetVariableSystemArray* + } + # # NOTE: Has field testing support been disabled? # if {![info exists no(testFields)]} then { # @@ -1586,10 +1701,16 @@ # NOTE: For test "object-2.1". # checkForObjectMember $test_channel Eagle._Tests.Default \ *TestComplexMethod* + # + # NOTE: For test "object-2.12". + # + checkForObjectMember $test_channel Eagle._Tests.Default \ + *TestMoreComplexMethod* + # # NOTE: For test "object-2.3". # checkForObjectMember $test_channel Eagle._Tests.Default \ *TestToHexadecimalString* @@ -2024,11 +2145,11 @@ # # NOTE: Has all use of [exec] for tests been disabled? # if {![info exists no(checkForTestExec)]} then { - checkForTestExec $test_channel + checkForTestExec $test_channel [haveConstraint quiet] } # # NOTE: Has checking for the test machine been disabled? # @@ -2331,10 +2452,14 @@ } if {![info exists no(checkForBigLists)]} then { checkForBigLists $test_channel } + + if {![info exists no(checkForMemoryIntensive)]} then { + checkForMemoryIntensive $test_channel + } if {![info exists no(checkForStackIntensive)]} then { checkForStackIntensive $test_channel } @@ -2421,11 +2546,11 @@ # # NOTE: Has namespace detection support been disabled? # if {![info exists no(namespaces)]} then { - checkForNamespaces $test_channel + checkForNamespaces $test_channel [haveConstraint quiet] } # # NOTE: Check for various features that were added through # the TIP process. @@ -2456,10 +2581,14 @@ if {![info exists no(tip426)]} then { checkForTip426 $test_channel } + if {![info exists no(tip429)]} then { + checkForTip429 $test_channel + } + # # NOTE: Has performance testing been disabled? # if {![info exists no(core)] && \ ![info exists no(checkForPerformance)]} then { @@ -2480,11 +2609,19 @@ checkForTiming $test_channel 50; # 1/20th second. } if {![info exists no(core)] && \ ![info exists no(preciseTiming)]} then { - checkForTiming $test_channel 25 preciseTiming; # 1/40th second. + # + # NOTE: Normally, the "preciseTiming" constraint implicitly requires that + # the "timing" constraint be present as well; however, that can be + # overridden. + # + if {[info exists no(requireTiming)] || \ + [haveConstraint timing]} then { + checkForTiming $test_channel 25 preciseTiming; # 1/40th second. + } } # # NOTE: Has interactive testing been disabled? #