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/lib/Eagle1.0/init.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/init.eagle +++ Externals/Eagle/lib/Eagle1.0/init.eagle @@ -1535,42 +1535,49 @@ # # NOTE: Forget any previous commands that were imported from this # namespace into the global namespace? # if {$forget} then { - namespace forget ${namespace}::* + namespace eval :: [list namespace forget [appendArgs $namespace ::*]] } # - # NOTE: Process each of the commands to be exported from this + # NOTE: Process each command to be exported from the specified # namespace and import it into the global namespace, if # necessary. # foreach export $exports { # - # NOTE: Force importing of our exported commands into the - # global namespace? Otherwise, see if the command is - # already present in the global namespace before trying - # to import it. + # NOTE: Force importing of our exported commands into the global + # namespace? Otherwise, see if the command is already + # present in the global namespace before trying to import + # it. # - if {$force || [llength [info commands ::$export]] == 0} then { - namespace export $export + if {$force || \ + [llength [info commands [appendArgs :: $export]]] == 0} then { + # + # NOTE: Export the specified command from the specified namespace. + # + namespace eval $namespace [list namespace export $export] + + # + # NOTE: Import the specified command into the global namespace. + # + set namespaceExport [appendArgs $namespace :: $export] if {$force} then { - namespace eval :: [list namespace import -force \ - ${namespace}::$export] + namespace eval :: [list namespace import -force $namespaceExport] } else { - namespace eval :: [list namespace import \ - ${namespace}::$export] + namespace eval :: [list namespace import $namespaceExport] } } } } # - # NOTE: Exports the necessary commands from this package and import - # them into the global namespace. + # NOTE: Exports the necessary commands from this package and import them + # into the global namespace. # exportAndImportPackageCommands [namespace current] [list \ exportAndImportPackageCommands isEagle isMono getEnvironmentVariable \ getPluginPath getDictionaryValue getColumnValue getRowColumnValue \ appendArgs haveGaruda lappendArgs readFile filter map reduce \ Index: Externals/Eagle/lib/Eagle1.0/test.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/test.eagle +++ Externals/Eagle/lib/Eagle1.0/test.eagle @@ -170,11 +170,11 @@ if {[string length $fileName] > 0} then { if {[file exists $fileName]} then { tputs $::test_channel [appendArgs \ "---- evaluating $type file: \"" $fileName \"\n] - if {[catch {uplevel 1 [list source $fileName]} error] != 0} then { + if {[catch {uplevel 1 [list source $fileName]} error]} then { tputs $::test_channel [appendArgs \ "---- error during $type file: " $error \n] # # NOTE: The error has been logged, now re-throw it. @@ -695,11 +695,11 @@ catch {set array(tclthreads,$index) [llength [tcl threads]]} catch {set array(tclcommands,$index) [llength [tcl command list]]} } } - proc reportTestStatistics { channel fileName varName } { + proc reportTestStatistics { channel fileName statsVarName filesVarName } { set statistics [list afters variables commands procedures files \ temporaryFiles channels aliases interpreters environment] if {[isEagle]} then { # @@ -713,14 +713,16 @@ } # # NOTE: Show what leaked, if anything. # - upvar 1 $varName array + set count 0; upvar 1 $statsVarName array foreach statistic $statistics { if {$array($statistic,after) > $array($statistic,before)} then { + incr count + tputs $channel [appendArgs "==== \"" $fileName "\" LEAKED " \ $statistic \n] if {[info exists array($statistic,before,list)]} then { tputs $channel [appendArgs "---- " $statistic " BEFORE: " \ @@ -731,10 +733,21 @@ tputs $channel [appendArgs "---- " $statistic " AFTER: " \ $array($statistic,after,list) \n] } } } + + # + # NOTE: Make sure this file name is recorded in the list of file names with + # leaking tests. + # + upvar 1 $filesVarName fileNames + + if {$count > 0 && \ + [lsearch -exact $fileNames [file tail $fileName]] == -1} then { + lappend fileNames [file tail $fileName] + } } proc formatList { list {default ""} {columns 1} } { set count 1 set result "" @@ -876,13 +889,14 @@ # NOTE: So far, we have run no tests. # set count 0 # - # NOTE: So far, no files have had no files with failing tests. + # NOTE: So far, no files have had failing or leaking tests. # set failed [list] + set leaked [list] # # NOTE: Process each file name we have been given by the caller... # set total [llength $fileNames]; set lastPercent -1 @@ -1053,11 +1067,11 @@ # # NOTE: Determine if any resource leaks have occurred and # output diagnostics as necessary if they have. # - reportTestStatistics $channel $fileName leaks + reportTestStatistics $channel $fileName leaks leaked } } else { # # NOTE: This file does not actually count towards the total (i.e. # it contains no actual tests). @@ -1112,15 +1126,19 @@ tputs $channel [appendArgs "---- sourced " $count " test " \ [expr {$count > 1 ? "files" : "file"}] \n] # - # NOTE: Show the files that had failing tests. + # NOTE: Show the files that had failing and/or leaking tests. # if {[llength $failed] > 0} then { tputs $channel [appendArgs "---- files with failing tests: " $failed \n] } + + if {[llength $leaked] > 0} then { + tputs $channel [appendArgs "---- files with leaking tests: " $leaked \n] + } } proc configureTcltest { imports force } { if {[isEagle]} then { # @@ -1244,35 +1262,54 @@ } return 0; # no tests were run, etc. } - proc cleanupThread { thread } { - if {[$thread IsAlive]} then { - if {[catch {$thread Interrupt} error]} then { - tputs $::test_channel [appendArgs \ - "---- failed to interrupt test thread \"" \ - $thread "\": " $error \n] - } - - if {[$thread IsAlive]} then { - if {[catch {$thread Abort} error]} then { - tputs $::test_channel [appendArgs \ - "---- failed to abort test thread \"" \ - $thread "\": " $error \n] - } - - if {![$thread IsAlive]} then { - tputs $::test_channel [appendArgs \ - "---- test thread \"" $thread "\" aborted\n"] - - return true; # aborted? - } - } else { - tputs $::test_channel [appendArgs \ - "---- test thread \"" $thread "\" interrupted\n"] - + proc cleanupThread { thread {timeout 2000} } { + if {[$thread IsAlive]} then { + if {[catch {$thread Interrupt} error]} then { + tputs $::test_channel [appendArgs \ + "---- failed to interrupt test thread \"" $thread "\": " $error \ + \n] + } else { + tputs $::test_channel [appendArgs "---- test thread \"" $thread \ + "\" interrupted\n"] + } + + if {[$thread IsAlive]} then { + if {[catch {$thread Join $timeout} error]} then { + tputs $::test_channel [appendArgs \ + "---- failed to join test thread \"" $thread "\": " $error \n] + } elseif {$error} then { + tputs $::test_channel [appendArgs "---- joined test thread \"" \ + $thread \"\n] + } else { + tputs $::test_channel [appendArgs \ + "---- timeout joining test thread \"" $thread " (" $timeout \ + " milliseconds)\"\n"] + } + + if {[$thread IsAlive]} then { + if {[catch {$thread Abort} error]} then { + tputs $::test_channel [appendArgs \ + "---- failed to abort test thread \"" $thread "\": " $error \ + \n] + } else { + tputs $::test_channel [appendArgs "---- test thread \"" $thread \ + "\" aborted\n"] + } + + if {[$thread IsAlive]} then { + tputs $::test_channel [appendArgs "---- test thread \"" $thread \ + "\" appears to be a zombie\n"] + } else { + return true; # aborted? + } + } else { + return true; # joined? + } + } else { return true; # interrupted? } } else { return true; # already dead? } @@ -1279,34 +1316,116 @@ return false; # still alive (or error). } proc calculateBogoCops { {milliseconds 2000} } { + # + # NOTE: Save the current background error handler for later restoration + # and then reset the current background error handler to nothing. + # + set bgerror [interp bgerror {}] + interp bgerror {} "" + + try { + # + # NOTE: Save the current [after] flags for later restoration and then + # reset them to process events immediately. + # + set flags [after flags] + after flags =Immediate + + try { + set code [catch { + # + # NOTE: Schedule the event to cancel the script we are about to + # evaluate, capturing the name so we can cancel it later, if + # necessary. + # + set event [after $milliseconds [list interp cancel]] + + # + # HACK: There is the potential for a "race condition" here. If the + # specified number of milliseconds elapses before (or after) + # entering the [catch] script block (below) then the resulting + # script cancellation error will not be caught and we will be + # unable to return the correct result to the caller. + # + set before [info cmdcount] + catch {time {nop} -1}; # uses the [time] internal busy loop. + set after [info cmdcount] + + # + # HACK: Mono has a bug that results in excessive trailing zeros + # here (Mono bug #655780). + # + if {[isMono]} then { + expr {double(($after - $before) / ($milliseconds / 1000.0))} + } else { + expr {($after - $before) / ($milliseconds / 1000.0)} + } + } result] + + # + # NOTE: If we failed to calculate the number of commands-per-second + # due to some subtle race condition [as explained above], return + # an obviously invalid result instead. + # + if {$code == 0} then { + return $result + } else { + return 0 + } + } finally { + if {[info exists event]} then { + catch {after cancel $event} + } + + after flags =$flags + } + } finally { + interp bgerror {} $bgerror + } + } + + proc evalWithTimeout { script {milliseconds 2000} {resultVarName ""} } { + # + # NOTE: Save the current background error handler for later restoration + # and then reset the current background error handler to nothing. + # set bgerror [interp bgerror {}] interp bgerror {} "" try { + # + # NOTE: Save the current [after] flags for later restoration and then + # reset them to process events immediately. + # set flags [after flags] after flags =Immediate try { - set event [after $milliseconds [list interp cancel]] - - set before [info cmdcount] - catch {time {nop} -1}; # internal busy loop. - set after [info cmdcount] - - # - # HACK: Mono has a bug that results in excessive trailing zeros - # here (Mono bug #655780). - # - if {[isMono]} then { - return [expr \ - {double(($after - $before) / ($milliseconds / 1000.0))}] - } else { - return [expr {($after - $before) / ($milliseconds / 1000.0)}] - } + # + # NOTE: Evaluate the specified script in the context of the caller, + # returning the result to the caller. + # + if {[string length $resultVarName] > 0} then { + upvar 1 $resultVarName result + } + + return [catch { + # + # NOTE: Schedule the event to cancel the script we are about to + # evaluate, capturing the name so we can cancel it later, if + # necessary. + # + set event [after $milliseconds [list interp cancel]] + + # + # NOTE: Evaluate the script in the context of the caller. + # + uplevel 1 $script + } result] } finally { if {[info exists event]} then { catch {after cancel $event} } Index: Externals/Eagle/lib/Test1.0/constraints.eagle ================================================================== --- Externals/Eagle/lib/Test1.0/constraints.eagle +++ Externals/Eagle/lib/Test1.0/constraints.eagle @@ -123,10 +123,32 @@ } 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] && \ @@ -533,17 +555,19 @@ } else { tputs $channel no\n } } - proc checkForTiming { channel threshold } { + proc checkForTiming { channel threshold {tries 2} } { tputs $channel "---- checking for precision timing... " # - # NOTE: Are we allowed to do precision timing tests? + # 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. # - if {![info exists ::no(timing)]} then { + for {set try 0} {$try < $tries} {incr try} { # # NOTE: Attempt to block for exactly one second. # set start [expr {[clock clicks -milliseconds] & 0x7fffffff}] after 1000; # wait for "exactly" one second. @@ -557,21 +581,28 @@ # # 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. + # 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 - } + $threshold " milliseconds, tried " [expr {$try + 1}] \ + " " [expr {$try > 0 ? "times" : "time"}] ")\n"] + + # + # NOTE: We are done here, return now. + # + return + } + } + + tputs $channel [appendArgs "no (0 <= " $difference " > " \ + $threshold " milliseconds)\n"] } proc checkForPerformance { channel } { tputs $channel "---- checking for performance testing... " @@ -1643,13 +1674,13 @@ # exportAndImportPackageCommands [namespace current] [list checkForPlatform \ checkForEagle checkForGaruda checkForShell checkForDebug checkForTk \ checkForVersion checkForCommand checkForFile checkForNativeCode \ checkForTip127 checkForTip194 checkForTip241 checkForTip285 \ - checkForPerformance checkForTiming checkForInteractive checkForLogFile \ - checkForNetwork checkForCompileOption checkForUserInteraction] false \ - false + checkForPerformance checkForTiming checkForInteractive checkForSymbols \ + checkForLogFile checkForNetwork checkForCompileOption \ + checkForUserInteraction] 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 @@ -48,24 +48,28 @@ # actually point to the "lib\Eagle1.0" sub-directory under the # solution directory. # # WARNING: The Eagle package name and version are hard-coded here. # + set pkg_dir Eagle1.0; # TODO: Change me. + if {![file exists [file join $base_path lib]] || \ ![file isdirectory [file join $base_path lib]] || \ - ![file exists [file join $base_path lib Eagle1.0]] || \ - ![file isdirectory [file join $base_path lib Eagle1.0]] || \ - ![file exists [file join $base_path lib Eagle1.0 init.eagle]] || \ - ![file isfile [file join $base_path lib Eagle1.0 init.eagle]]} then { - # - # NOTE: We do not bother to check if the "lib" sub-directory - # actually exists as a child of this one. This is the - # previous (legacy) behavior (i.e. where we always went - # up two levels to the base directory). + ![file exists [file join $base_path lib $pkg_dir]] || \ + ![file isdirectory [file join $base_path lib $pkg_dir]] || \ + ![file exists [file join $base_path lib $pkg_dir init.eagle]] || \ + ![file isfile [file join $base_path lib $pkg_dir init.eagle]]} then { + # + # NOTE: We do not bother to check if the "lib" sub-directory actually + # exists as a child of this one. This is the previous (legacy) + # behavior (i.e. where we always went up two levels to the base + # directory). # set base_path [file dirname $base_path] } + + unset pkg_dir } # # NOTE: Set the local root directory of the source checkout (i.e. of # Eagle or whatever project the Eagle binaries are being used by). @@ -91,11 +95,11 @@ # trailing slashes. # set root_path [file normalize $directory] } - unset -nocomplain directory exec pattern + unset -nocomplain directory dummy exec pattern } # # NOTE: Set the executable file name for the process, if # necessary. @@ -656,10 +660,17 @@ # checkForDatabase $test_channel $test_database unset password user timeout database server } + # + # NOTE: Has symbol testing support been disabled? + # + 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 { # @@ -829,10 +840,20 @@ # # NOTE: For tests "commands-1.4", "object-7.3" and "xml-1.1.*". # checkForCompileOption $test_channel XML } + + # + # NOTE: Has serialization support been enabled (at compile-time)? + # + if {![info exists no(compileSerialization)]} then { + # + # NOTE: For test "interp-1.10". + # + checkForCompileOption $test_channel SERIALIZATION + } # # NOTE: Has dedicated test support been enabled (at compile-time)? # if {![info exists no(compileTest)]} then { @@ -1471,10 +1492,14 @@ } if {![info exists no(noLogFile)]} then { checkForLogFile $test_channel } + + if {![info exists no(symbols)]} then { + checkForSymbols $test_channel [info nameofexecutable] + } if {![info exists no(garuda)]} then { checkForGaruda $test_channel } @@ -1639,11 +1664,11 @@ # # HACK: We need something to go into the log file. # set timeStamp [lindex $timeStamp 0] } else { - set timeStamp [clock format [clock scan $timeStamp] -iso] + set timeStamp [clock format [clock scan $timeStamp] -iso -isotimezone] } } else { set timeStamp }