Index: Externals/Eagle/lib/Eagle1.0/init.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/init.eagle +++ Externals/Eagle/lib/Eagle1.0/init.eagle @@ -49,12 +49,12 @@ # NOTE: Is the Eagle Package for Tcl (Garuda) available? This check # is different in Eagle and Tcl. # if {[isEagle]} then { return [expr {[llength [info commands tcl]] > 0 && [tcl ready] && \ - [catch {tcl eval [tcl master] package present Garuda}] == 0 && \ - [catch {tcl eval [tcl master] garuda packageid} packageId] == 0}] + [catch {tcl eval [tcl master] {package present Garuda}}] == 0 && \ + [catch {tcl eval [tcl master] {garuda packageid}} packageId] == 0}] } else { return [expr {[catch {package present Garuda}] == 0 && \ [catch {garuda packageid} packageId] == 0}] } } @@ -298,14 +298,14 @@ proc readFile { fileName } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName RDONLY] - fconfigure $file_id -encoding binary -translation binary; # BINARY DATA - set result [read $file_id] - close $file_id + set channel [open $fileName RDONLY] + fconfigure $channel -encoding binary -translation binary; # BINARY DATA + set result [read $channel] + close $channel return $result } proc readSharedFile { fileName } { # @@ -324,48 +324,48 @@ # # NOTE: Open the file using the command constructed above, configure # the channel for binary data, and output the data to it. # - set file_id [eval $command] - fconfigure $file_id -encoding binary -translation binary; # BINARY DATA - set result [read $file_id] - close $file_id + set channel [eval $command] + fconfigure $channel -encoding binary -translation binary; # BINARY DATA + set result [read $channel] + close $channel return $result } proc writeFile { fileName data } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName {WRONLY CREAT TRUNC}] - fconfigure $file_id -encoding binary -translation binary; # BINARY DATA - puts -nonewline $file_id $data - close $file_id + set channel [open $fileName {WRONLY CREAT TRUNC}] + fconfigure $channel -encoding binary -translation binary; # BINARY DATA + puts -nonewline $channel $data + close $channel return "" } proc appendFile { fileName data } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName {WRONLY CREAT APPEND}] - fconfigure $file_id -encoding binary -translation binary; # BINARY DATA - puts -nonewline $file_id $data - close $file_id + set channel [open $fileName {WRONLY CREAT APPEND}] + fconfigure $channel -encoding binary -translation binary; # BINARY DATA + puts -nonewline $channel $data + close $channel return "" } proc appendLogFile { fileName data } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName {WRONLY CREAT APPEND}] - fconfigure $file_id -encoding binary -translation \ + set channel [open $fileName {WRONLY CREAT APPEND}] + fconfigure $channel -encoding binary -translation \ [expr {[isEagle] ? "protocol" : "auto"}]; # LOG DATA - puts -nonewline $file_id $data - close $file_id + puts -nonewline $channel $data + close $channel return "" } proc appendSharedFile { fileName data } { # @@ -384,14 +384,14 @@ # # NOTE: Open the file using the command constructed above, configure # the channel for binary data, and output the data to it. # - set file_id [eval $command] - fconfigure $file_id -encoding binary -translation binary; # BINARY DATA - puts -nonewline $file_id $data; flush $file_id - close $file_id + set channel [eval $command] + fconfigure $channel -encoding binary -translation binary; # BINARY DATA + puts -nonewline $channel $data; flush $channel + close $channel return "" } proc appendSharedLogFile { fileName data } { # @@ -410,59 +410,59 @@ # # NOTE: Open the file using the command constructed above, configure # the channel for binary data, and output the data to it. # - set file_id [eval $command] - fconfigure $file_id -encoding binary -translation \ + set channel [eval $command] + fconfigure $channel -encoding binary -translation \ [expr {[isEagle] ? "protocol" : "auto"}]; # LOG DATA - puts -nonewline $file_id $data; flush $file_id - close $file_id + puts -nonewline $channel $data; flush $channel + close $channel return "" } proc readAsciiFile { fileName } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName RDONLY] - fconfigure $file_id -encoding ascii -translation auto; # ASCII TEXT - set result [read $file_id] - close $file_id + set channel [open $fileName RDONLY] + fconfigure $channel -encoding ascii -translation auto; # ASCII TEXT + set result [read $channel] + close $channel return $result } proc writeAsciiFile { fileName data } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName {WRONLY CREAT TRUNC}] - fconfigure $file_id -encoding ascii -translation auto; # ASCII TEXT - puts -nonewline $file_id $data - close $file_id + set channel [open $fileName {WRONLY CREAT TRUNC}] + fconfigure $channel -encoding ascii -translation auto; # ASCII TEXT + puts -nonewline $channel $data + close $channel return "" } proc readUnicodeFile { fileName } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName RDONLY] - fconfigure $file_id -encoding unicode -translation auto; # UNICODE TEXT - set result [read $file_id] - close $file_id + set channel [open $fileName RDONLY] + fconfigure $channel -encoding unicode -translation auto; # UNICODE TEXT + set result [read $channel] + close $channel return $result } proc writeUnicodeFile { fileName data } { # # NOTE: This should work properly in both Tcl and Eagle. # - set file_id [open $fileName {WRONLY CREAT TRUNC}] - fconfigure $file_id -encoding unicode -translation auto; # UNICODE TEXT - puts -nonewline $file_id $data - close $file_id + set channel [open $fileName {WRONLY CREAT TRUNC}] + fconfigure $channel -encoding unicode -translation auto; # UNICODE TEXT + puts -nonewline $channel $data + close $channel return "" } proc getDirResultPath { pattern path } { # @@ -1160,11 +1160,11 @@ } proc runUpdateAndExit {} { set directory [file dirname [info nameofexecutable]] - set command [list exec -- \ + set command [list exec -shell -- \ [file join $directory Hippogriff.exe] -delay 2000] eval $command &; exit -force } @@ -1214,11 +1214,11 @@ # NOTE: This proc is used to check for new versions -OR- new update # scripts for the runtime when a user executes the interactive # "#check" command. To disable this functionality, simply # redefine this procedure to do nothing. # - proc checkForUpdate { {wantScripts false} } { + proc checkForUpdate { {wantScripts false} {quiet false} } { # # NOTE: This should work properly in Eagle only. # set updateUri [appendArgs [info engine Uri] [info engine UpdateFile]] @@ -1234,11 +1234,14 @@ set lines [split $updateData \n] # # NOTE: Keep track of how many update scripts are processed. # - set scriptCount 0 + array set scriptCount { + invalid 0 fail 0 bad 0 + ok 0 error 0 + } # # NOTE: Check each line to find the build information... # foreach line $lines { @@ -1317,32 +1320,96 @@ if {[string length $patchLevel] == 0} then { set patchLevel 0.0.0.0; # no patch level? } + # + # NOTE: Grab the time-stamp field. + # + set timeStamp [lindex $fields 5] + + if {[string length $timeStamp] == 0} then { + set timeStamp 0; #never? + } + + # + # NOTE: Does it look like the number of seconds since the epoch + # or some kind of date/time string? + # + if {[string is integer -strict $timeStamp]} then { + set dateTime [clock format $timeStamp] + } else { + set dateTime [clock format [clock scan $timeStamp]] + } + # # NOTE: Grab the patch level for the running engine. # set enginePatchLevel [info engine PatchLevel] # - # NOTE: Compare the patch level from the line to the one we - # are currently using. + # NOTE: Grab the time-stamp for the running engine. + # + set engineTimeStamp [info engine TimeStamp] + + if {[string length $engineTimeStamp] == 0} then { + set engineTimeStamp 0; #never? + } + + # + # NOTE: Does it look like the number of seconds since the epoch + # or some kind of date/time string? + # + if {[string is integer -strict $engineTimeStamp]} then { + set engineDateTime [clock format $engineTimeStamp] + } else { + set engineDateTime [clock format [clock scan $engineTimeStamp]] + } + + # + # NOTE: For build lines, compare the patch level from the line + # to the one we are currently using using a simple patch + # level comparison. + # + if {$checkBuild} then { + set compare [package vcompare $patchLevel $enginePatchLevel] + } else { + # + # NOTE: This is not a build line, no match. + # + set compare -1 + } + + # + # NOTE: For script lines, use regular expression matching. # - set compare [package vcompare $patchLevel $enginePatchLevel] - - if {($checkBuild && $compare > 0) || \ - ($checkScript && $compare == 0)} then { + if {$checkScript} then { # - # NOTE: Grab the time-stamp field. + # NOTE: Use [catch] here to prevent raising a script error + # due to a malformed patch level regular expression. # - set timeStamp [lindex $fields 5] - - if {[string length $timeStamp] == 0} then { - set timeStamp 0; #never? + if {[catch { + regexp -nocase -- $patchLevel $enginePatchLevel + } match]} then { + # + # NOTE: The patch level from the script line was most + # likely not a valid regular expression. + # + set match false } + } else { + # + # NOTE: This is not a script line, no match. + # + set match false + } + # + # NOTE: Are we interested in further processing this line? + # + if {($checkBuild && $compare > 0) || + ($checkScript && $match)} then { # # NOTE: Grab the base URI field (i.e. it may be a mirror # site). # set baseUri [lindex $fields 6] @@ -1358,28 +1425,20 @@ if {[string length $notes] > 0} then { set notes [unescapeUpdateNotes $notes] } - # - # NOTE: Does it look like the number of seconds since the - # epoch or some kind of date/time string? - # - if {[string is integer -strict $timeStamp]} then { - set dateTime [clock format $timeStamp] - } else { - set dateTime [clock format [clock scan $timeStamp]] - } - # # NOTE: The engine patch level from the line is greater, # we are out-of-date. Return the result of our # checking now. # if {$checkBuild} then { - return [list [appendArgs "newer build " $patchLevel \ - " is available as of " $dateTime] [list $baseUri \ + return [list [appendArgs \ + "latest build " $patchLevel ", dated " $dateTime \ + ", is newer than running build " $enginePatchLevel \ + ", dated " $engineDateTime] [list $baseUri \ $patchLevel] [list $notes]] } # # NOTE: The script patch level from the line matches the @@ -1402,15 +1461,16 @@ # NOTE: Next, verify the script has a valid base URI. # For update scripts, this must be the location # where the update script data can be downloaded. # if {[string length $baseUri] == 0} then { - tqputs $channel [appendArgs \ - "---- invalid baseUri value for update script line: " \ - $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- invalid baseUri value for update script " \ + "line: " $line \"\n] + } + incr scriptCount(invalid); continue } # # NOTE: Next, grab the md5 field and see if it looks valid. # Below, the value of this field will be compared to @@ -1418,15 +1478,16 @@ # data. # set lineMd5 [lindex $fields 7] if {[string length $lineMd5] == 0} then { - tqputs $channel [appendArgs \ - "---- invalid md5 value for update script line: " \ - $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- invalid md5 value for update script " \ + "line: " $line \"\n] + } + incr scriptCount(invalid); continue } # # NOTE: Next, grab the sha1 field and see if it looks valid. # Below, the value of this field will be compared to @@ -1434,15 +1495,16 @@ # data. # set lineSha1 [lindex $fields 8] if {[string length $lineSha1] == 0} then { - tqputs $channel [appendArgs \ - "---- invalid sha1 value for update script line: " \ - $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- invalid sha1 value for update script " \ + "line: " $line \"\n] + } + incr scriptCount(invalid); continue } # # NOTE: Next, grab the sha512 field and see if it looks # valid. Below, the value of this field will be @@ -1450,30 +1512,33 @@ # downloaded script data. # set lineSha512 [lindex $fields 9] if {[string length $lineSha512] == 0} then { - tqputs $channel [appendArgs \ - "---- invalid sha512 value for update script line: " \ - $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- invalid sha512 value for update script " \ + "line: " $line \"\n] + } + incr scriptCount(invalid); continue } # # NOTE: Next, show the extra information associated with # this update script, if any. # - tqputs $channel [appendArgs \ - "---- fetching update script from \"" $baseUri "\" (" \ - $dateTime ") with notes:\n"] + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- fetching update script from \"" $baseUri \ + "\" (" $dateTime ") with notes:\n"] - set trimNotes [string trim $notes] + set trimNotes [string trim $notes] - tqputs $channel [appendArgs \ - [expr {[string length $trimNotes] > 0 ? $trimNotes : \ - ""}] "\n---- end of update script notes\n"] + tqputs $channel [appendArgs \ + [expr {[string length $trimNotes] > 0 ? $trimNotes : \ + ""}] "\n---- end of update script notes\n"] + } # # NOTE: Next, attempt to fetch the update script data. # set code [catch {getUpdateScriptData $baseUri} result] @@ -1485,14 +1550,15 @@ set scriptData $result } else { # # NOTE: Failure, report the error message to the log. # - tqputs $channel [appendArgs \ - "---- failed to fetch update script: " $result \n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- failed to fetch update script: " $result \n] + } + incr scriptCount(fail); continue } # # NOTE: Next, verify that the md5, sha1, and sha512 # hashes of the raw script data match what was @@ -1499,44 +1565,49 @@ # specified in the md5, sha1, and sha512 fields. # set scriptMd5 [hash normal md5 $scriptData] if {![string equal -nocase $lineMd5 $scriptMd5]} then { - tqputs $channel [appendArgs \ - "---- wrong md5 value \"" $scriptMd5 \ - "\" for update script line: " $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- wrong md5 value \"" $scriptMd5 \ + "\" for update script line: " $line \"\n] + } + incr scriptCount(bad); continue } set scriptSha1 [hash normal sha1 $scriptData] if {![string equal -nocase $lineSha1 $scriptSha1]} then { - tqputs $channel [appendArgs \ - "---- wrong sha1 value \"" $scriptSha1 \ - "\" for update script line: " $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- wrong sha1 value \"" $scriptSha1 \ + "\" for update script line: " $line \"\n] + } + incr scriptCount(bad); continue } set scriptSha512 [hash normal sha512 $scriptData] if {![string equal -nocase $lineSha512 $scriptSha512]} then { - tqputs $channel [appendArgs \ - "---- wrong sha512 value \"" $scriptSha512 \ - "\" for update script line: " $line \"\n] - - continue + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- wrong sha512 value \"" $scriptSha512 \ + "\" for update script line: " $line \"\n] + } + incr scriptCount(bad); continue } # # NOTE: Finally, everything looks good. Therefore, just # evaluate the update script and print the result. # - tqputs $channel [appendArgs \ - "---- evaluating update script from \"" $baseUri \ - \"...\n] + if {!$quiet} then { + tqputs $channel [appendArgs \ + "---- evaluating update script from \"" $baseUri \ + \"...\n] + } # # NOTE: Reset the variables that will be used to contain # the result of the update script. # @@ -1563,25 +1634,41 @@ # object invoke -flags +NonPublic Interpreter.GetActive \ PopScriptLocation true } - host result $code $result; incr scriptCount - tqputs $channel "\n---- end of update script results\n" + # + # NOTE: Keep track of the number of update scripts that + # generate Ok and Error return codes. + # + if {$code == 0} then { + incr scriptCount(ok) + } else { + incr scriptCount(error) + } + + if {!$quiet} then { + host result $code $result + tqputs $channel "\n---- end of update script results\n" + } } } elseif {$checkBuild && $compare < 0} then { # # NOTE: The patch level from the line is less, we are more # up-to-date than the latest version? # - return [list [appendArgs "running build " $enginePatchLevel \ - " is newer than the latest build " $patchLevel]] + return [list [appendArgs \ + "running build " $enginePatchLevel ", dated " \ + $engineDateTime ", is newer than latest build " \ + $patchLevel ", dated " $dateTime]] } elseif {$checkBuild} then { # # NOTE: The patch levels are equal, we are up-to-date. # - return [list "running build is the latest"] + return [list [appendArgs \ + "running build " $enginePatchLevel ", dated " \ + $engineDateTime ", is the latest build"]] } } } } } @@ -1591,18 +1678,21 @@ # to this point when checking for a new build, something # must have gone awry. Otherwise, report the number of # update scripts that were successfully processed. # if {$wantScripts} then { - if {$scriptCount > 0} then { + set scriptCount(total) [expr [join [array values scriptCount] +]] + + if {$scriptCount(total) > 0} then { return [list [appendArgs \ - "processed " $scriptCount " update scripts"]] + "processed " $scriptCount(total) " update scripts: " \ + [array get scriptCount]]] } else { return [list "no update scripts were processed"] } } else { - return [list "cannot determine if running build is the latest"] + return [list "could not determine if running build is the latest"] } } proc getReturnType { object member } { if {[string length $object] == 0 || [string length $member] == 0} then { Index: Externals/Eagle/lib/Eagle1.0/shell.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/shell.eagle +++ Externals/Eagle/lib/Eagle1.0/shell.eagle @@ -27,11 +27,15 @@ # # NOTE: Commands specific to initializing the Eagle interactive shell # environment should be placed here. # - + proc help { args } { + eval lappend command #help $args; debug icommand $command + error "for interactive help please use: #help $args" + } + ########################################################################### ############################# END Eagle ONLY ############################## ########################################################################### } else { ########################################################################### Index: Externals/Eagle/lib/Eagle1.0/test.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/test.eagle +++ Externals/Eagle/lib/Eagle1.0/test.eagle @@ -474,13 +474,18 @@ # NOTE: Now, attempt to flush the test log queue, if available. # tlog "" } - proc getTclShellFileName {} { + proc getTclShellFileName { automatic } { # - # NOTE: Check the environment variables we know about that + # NOTE: Start out with an empty list of candiate Tcl shells. + # + set shells [list] + + # + # NOTE: Check all environment variables we know about that # may contain the path where the Tcl shell is located. # foreach name [list Eagle_Tcl_Shell Tcl_Shell] { set value [getEnvironmentVariable $name] @@ -488,19 +493,95 @@ # TODO: Possibly add a check if the file actually exists # here. # if {[string length $value] > 0} then { # - # NOTE: *EXTERNAL* Return verbatim, no normalization. - # - return $value - } - } - - # - # NOTE: None of the environment variables returned anything - # valid, return the fallback default. + # NOTE: *EXTERNAL* Use verbatim, no normalization. + # + if {$automatic} then { + # + # NOTE: In automatic mode, the environment variable + # value simply represents another candidate + # Tcl shell (i.e. it does not halt the search + # for other candidate Tcl shells). + # + lappend shells $value + } else { + # + # NOTE: In manual mode, the environment variable + # value represents an "override" and halts + # the search for other candidate Tcl shells. + # + return $value + } + } + } + + # + # NOTE: The automatic Tcl shell detection is only available when + # running in Eagle. + # + if {[isEagle]} then { + # + # NOTE: Attempt to check for the "best" available dynamically + # loadable Tcl library and then attempt to use its + # "associated" Tcl shell. A very similar block of code + # is also used by the [checkForTclInstalls] procedure + # in the constraints package. + # + if {[catch {tcl select -architecture} tcl] == 0} then { + # + # NOTE: Did we find one? Attempt to grab the index of the + # version field from the returned dictionary value. + # + set dotVersion [getDictionaryValue $tcl version] + + # + # NOTE: Verify that the version we found is valid and that + # it conforms to the pattern we expect. + # + if {[string length $dotVersion] > 0 && \ + [regexp -- {^\d+\.\d+$} $dotVersion]} then { + # + # NOTE: Gather the list of candidate Tcl shells to check + # using the range of versions we are interested in, + # starting with the "best" available version and + # ending with the absolute minimum version supported + # by the Eagle core library. A very similar block + # of code is also used by the [checkForTclShell] + # procedure in the constraints package. + # + foreach version [lsort -real -decreasing [tcl \ + versionrange -maximumversion $dotVersion]] { + lappend shells [appendArgs \ + tclsh [string map [list . ""] $version]] + + lappend shells [appendArgs tclsh $version] + } + } + } + + # + # NOTE: Check each candidate Tcl shell and query its fully + # qualified path from it. If it cannot be executed, + # we know that candidate Tcl shell is not available. + # + foreach shell $shells { + if {[catch { + getTclExecutableForTclShell $shell + } executable] == 0 && $executable ne "error"} then { + # + # NOTE: It looks like this Tcl shell is available. + # Return the fully qualified path to it now. + # + return $executable + } + } + } + + # + # NOTE: Return the fallback default. # return tclsh } proc getTemporaryPath {} { @@ -1341,10 +1422,22 @@ return $result } proc formatDecimal { value {places 4} {zeros false} } { + # + # NOTE: If the value is an empty string, do nothing and return an empty + # string. + # + if {[string length $value] == 0} then { + return "" + } + + # + # NOTE: For now, use slightly different methods for formatting floating + # pointer numbers for native Tcl and Eagle. + # if {[isEagle] && [llength [info commands object]] > 0} then { # # HACK: This works; however, in order to do this kind of thing cleanly, # we really need the Tcl [format] command. # @@ -1356,10 +1449,23 @@ } else { # # NOTE: See, nice and clean when done in Tcl? # set result [format [appendArgs %. $places f] $value] + + # + # HACK: Since native Tcl does not appear to expose a method to only + # preserve non-zero trailing digits, we may need to manually + # remove extra trailing zeros. + # + if {!$zeros} then { + # + # NOTE: Remove all trailing zeros and the trailing decimal point, + # if necessary. + # + set result [string trimright [string trimright $result 0] .] + } } return $result } @@ -1920,21 +2026,21 @@ # if {[llength [info commands testConstraint]] == 0} then { interp alias {} testConstraint {} haveOrAddConstraint if {!$quiet} then { - tqputs [getTestChannelOrDefault] [appendArgs \ - "---- added \"testConstraint\" alias\n"] + tqputs [getTestChannelOrDefault] \ + "---- added \"testConstraint\" alias\n" } } if {[llength [info commands ::tcltest::testConstraint]] == 0} then { interp alias {} ::tcltest::testConstraint {} haveOrAddConstraint if {!$quiet} then { - tqputs [getTestChannelOrDefault] [appendArgs \ - "---- added \"::tcltest::testConstraint\" alias\n"] + tqputs [getTestChannelOrDefault] \ + "---- added \"::tcltest::testConstraint\" alias\n" } } # # NOTE: This is needed by most tests in the Tcl test suite. Make @@ -1942,12 +2048,12 @@ # if {[llength [info commands ::tcltest::cleanupTests]] == 0} then { proc ::tcltest::cleanupTests { args } {} if {!$quiet} then { - tqputs [getTestChannelOrDefault] [appendArgs \ - "---- added \"::tcltest::cleanupTests\" procedure\n"] + tqputs [getTestChannelOrDefault] \ + "---- added \"::tcltest::cleanupTests\" procedure\n" } } } else { # # NOTE: Remove the compatibility shim command aliases that we setup @@ -1956,31 +2062,31 @@ if {[lsearch -exact [info commands] \ ::tcltest::cleanupTests] != -1} then { rename ::tcltest::cleanupTests "" if {!$quiet} then { - tqputs $::test_channel [appendArgs \ - "---- removed \"::tcltest::cleanupTests\" procedure\n"] + tqputs $::test_channel \ + "---- removed \"::tcltest::cleanupTests\" procedure\n" } } if {[lsearch -exact [interp aliases] \ ::tcltest::testConstraint] != -1} then { interp alias {} ::tcltest::testConstraint {} {} if {!$quiet} then { - tqputs $::test_channel [appendArgs \ - "---- removed \"::tcltest::testConstraint\" alias\n"] + tqputs $::test_channel \ + "---- removed \"::tcltest::testConstraint\" alias\n" } } if {[lsearch -exact [interp aliases] testConstraint] != -1} then { interp alias {} testConstraint {} {} if {!$quiet} then { - tqputs $::test_channel [appendArgs \ - "---- removed \"testConstraint\" alias\n"] + tqputs $::test_channel \ + "---- removed \"testConstraint\" alias\n" } } } } @@ -2136,11 +2242,11 @@ } finally { interp bgerror {} $bgerror } } - proc testExecTclScript { script } { + proc testExecTclScript { script {shell ""} } { 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. # @@ -2151,17 +2257,38 @@ # supplied via the command line, write the script to be # evaluated to the temporary file. # writeFile $fileName $script + # + # NOTE: Use the specified shell, if it is valid; otherwise, use + # the configured Tcl shell. + # + if {[string length $shell] == 0} then { + # + # NOTE: Before attempting to use the configured Tcl shell, make + # sure it has actually been set. + # + if {[info exists ::test_tclsh] && \ + [string length $::test_tclsh] > 0} then { + set shell $::test_tclsh + } else { + # + # NOTE: We cannot execute the native Tcl shell because one + # has not been specified, nor configured. + # + return error + } + } + # # NOTE: Evaluate the script using the native Tcl shell, trim the # excess whitespace from the output, and return it to the # caller. # if {[catch {string trim \ - [testExec $::test_tclsh [list -success Success] \ + [testExec $shell [list -success Success] \ [appendArgs \" $fileName \"]]} result] == 0} then { # # NOTE: Success, return the result to the caller. # return $result @@ -2186,32 +2313,38 @@ catch {file delete $fileName} } } } - proc getTclVersionForTclShell {} { + proc getTclVersionForTclShell { {shell ""} } { return [testExecTclScript { puts -nonewline stdout [info tclversion] - }] + } $shell] } - proc getCommandsForTclShell {} { + proc getCommandsForTclShell { {shell ""} } { return [testExecTclScript { puts -nonewline stdout [info commands] - }] + } $shell] } - proc getMachineForTclShell {} { + proc getMachineForTclShell { {shell ""} } { return [testExecTclScript { puts -nonewline stdout $tcl_platform(machine) - }] + } $shell] + } + + proc getTclExecutableForTclShell { {shell ""} } { + return [testExecTclScript { + puts -nonewline stdout [info nameofexecutable] + } $shell] } - proc getTkVersionForTclShell {} { + proc getTkVersionForTclShell { {shell ""} } { return [testExecTclScript { puts -nonewline stdout [package require Tk]; exit - }] + } $shell] } proc getGarudaDll {} { # # NOTE: Get the Garuda DLL of the same platform (i.e. machine type) Index: Externals/Eagle/lib/Eagle1.0/vendor.eagle ================================================================== --- Externals/Eagle/lib/Eagle1.0/vendor.eagle +++ Externals/Eagle/lib/Eagle1.0/vendor.eagle @@ -227,11 +227,20 @@ # interpreter to point directly to it. # if {[string length $vendor_directory] > 0} then { setupInterpreterTestPath stdout $vendor_directory false } + + # + # HACK: Prevent the Eagle core test suite infrastructure from doing + # things that require beta 29 (or later) binaries. This section + # should be removed when the Eagle beta 29 binaries are checked + # into the System.Data.SQLite repository. + # + set ::no(getTclShellFileName) 1; # NOTE: Lack of [tcl versionrange]. + set ::no(testSuiteFiles) 1; # NOTE: Lack of [hash -filename]. } } ############################################################################### ############################### END VENDOR CODE ############################### ############################################################################### Index: Externals/Eagle/lib/Test1.0/constraints.eagle ================================================================== --- Externals/Eagle/lib/Test1.0/constraints.eagle +++ Externals/Eagle/lib/Test1.0/constraints.eagle @@ -109,16 +109,23 @@ if {[isEagle] || [catch {package require sha1}] == 0} then { tputs $channel yes\n foreach fileName $fileNames { if {[isEagle]} then { - set sha1 [hash normal sha1 [readFile $fileName]] + # + # NOTE: Use the relatively new -filename option to the Eagle + # [hash] command. + # + set sha1 [hash normal -filename sha1 $fileName] } else { # # BUGBUG: Apparently, the ActiveState tcllib sha1 package may # have a bug that produces the wrong values here. No # attempt is made here to work around any such bug. + # For further information, please see: + # + # http://core.tcl.tk/tcllib/info/ad20454023 # set sha1 [sha1::sha1 -hex -filename $fileName] } tputs $channel [appendArgs \ @@ -397,11 +404,11 @@ } proc checkForFossil { channel } { tputs $channel "---- checking for Fossil... " - if {[catch {set version [exec -- fossil version]}] == 0} then { + if {[catch {exec -- fossil version} version] == 0} then { set version [string trim $version] set pattern {^This is fossil version (.*) \[([0-9a-f]+)\]\ \d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2} UTC$} if {[regexp -- $pattern $version dummy version sourceId]} then { @@ -414,11 +421,11 @@ # # NOTE: Append the version of Fossil currently in use. # append result version " " $version " \[" $sourceId \] - if {[catch {set remote [exec -- fossil remote]}] == 0} then { + if {[catch {exec -- fossil remote} remote] == 0} then { set remote [string trim $remote]; set valid false if {[isEagle]} then { # # NOTE: With Eagle, we can actually validate the URI. @@ -1174,10 +1181,44 @@ tputs $channel yes\n } else { tputs $channel no\n } } + + proc checkForBigLists { channel } { + tputs $channel "---- checking for big list testing... " + + # + # NOTE: Are we allowed to do big list testing? + # + if {![info exists ::no(bigLists)]} then { + if {[isEagle]} then { + # + # MONO: Using the native utility library when running on Mono to + # join big lists seems to cause StackOverflowException to + # be thrown. + # + if {[info exists ::no(mono)] || ![isMono] || \ + ![haveConstraint nativeUtility]} then { + # + # NOTE: Yes, it appears that it is available. + # + addConstraint bigLists + + tputs $channel yes\n + } else { + tputs $channel "no, broken on Mono with native utility\n" + } + } else { + addConstraint bigLists + + tputs $channel yes\n + } + } else { + tputs $channel no\n + } + } proc checkForStackIntensive { channel } { tputs $channel "---- checking for stack intensive testing... " # @@ -1281,11 +1322,12 @@ if {[isEagle]} then { # # NOTE: Running this check on the Mono 3.3.0 release build will lock # up the process; therefore, attempt to skip it in that case. # - if {![isMono] || ![haveConstraint mono33]} then { + if {[info exists ::no(mono)] || ![isMono] || \ + ![haveConstraint mono33]} 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). # @@ -1376,12 +1418,12 @@ 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 { + [catch {uri softwareupdates} trust] == 0 && \ + $trust eq "software update certificate is trusted"} then { # # NOTE: Yes, it appears that we trust our software updates. # Since this setting is off by default, the user (or # a script evaluated by the user) must have manually # turned it on. @@ -1546,32 +1588,32 @@ } proc checkForHost { channel } { tputs $channel "---- checking for host... " - if {[catch {host isopen} result] == 0} then { - if {$result} then { + if {[catch {host isopen} open] == 0} then { + if {$open} then { addConstraint hostIsOpen tputs $channel open\n } else { - if {[catch {host redirected Input} result] == 0} then { - if {$result} then { + if {[catch {host redirected Input} redirected] == 0} then { + if {$redirected} then { addConstraint hostInputRedirected tputs $channel redirected\n } else { addConstraint hostIsClosed tputs $channel closed\n } } else { - tlog $result; tputs $channel error\n] + tlog $redirected; tputs $channel error\n } } } else { - tlog $result; tputs $channel error\n] + tlog $open; tputs $channel error\n } } proc checkForHostType { channel } { tputs $channel "---- checking for host type... " @@ -1627,11 +1669,11 @@ tputs $channel "---- checking for runtime... " # # NOTE: Are we running inside Mono (regardless of operating system)? # - if {[isMono]} then { + if {![info exists ::no(mono)] && [isMono]} then { # # NOTE: Yes, it appears that we are running inside Mono. # addConstraint mono; # running on Mono. @@ -1734,11 +1776,11 @@ # 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 {![info exists ::no(mono)] && [isMono]} then { # # NOTE: If the runtime version was found, add a test constraint # for it now. # if {[string length $version] > 0} then { @@ -1887,11 +1929,11 @@ # addConstraint [appendArgs culture. [string map [list - _] $culture]] tputs $channel [appendArgs $culture \n] } else { - tputs $channel [appendArgs unknown \n] + tputs $channel unknown\n } } proc checkForThreadCulture { channel } { tputs $channel "---- checking for thread culture... " @@ -1910,11 +1952,11 @@ addConstraint [appendArgs threadCulture. [string map [list - _] \ $culture]] tputs $channel [appendArgs $culture \n] } else { - tputs $channel [appendArgs unknown \n] + tputs $channel unknown\n } } proc checkForQuiet { channel } { tputs $channel "---- checking for quiet... " @@ -2201,18 +2243,67 @@ } proc checkForTclReady { channel } { tputs $channel "---- checking for Tcl readiness... " - if {[catch {tcl ready} result] == 0 && $result} then { + if {[catch {tcl ready} ready] == 0 && $ready} then { # # NOTE: Yes, native Tcl is loaded and ready. # addConstraint tclReady - tputs $channel yes\n + # + # NOTE: Yes, native Tcl is ready -OR- available. + # + addConstraint tclReadyOrLibrary + + # + # NOTE: Ok, attempt to determine the loaded Tcl version. + # + if {[catch { + tcl eval [tcl master] {info tclversion} + } version] == 0 && [regexp -- {^\d+\.\d+$} $version]} then { + addConstraint [appendArgs \ + tclReady [string map [list . ""] $version]] + + # + # NOTE: The Tcl library is ready; however, we need to add the + # appropriate test constraint to indicate that a specific + # version of Tcl is "either ready or available". + # + if {[haveConstraint tclLibrary86] && $version >= 8.6} then { + addConstraint tclReadyOrLibrary86 + } elseif {[haveConstraint tclLibrary85] && $version >= 8.5} then { + addConstraint tclReadyOrLibrary85 + } elseif {[haveConstraint tclLibrary84] && $version >= 8.4} then { + addConstraint tclReadyOrLibrary84 + } + + tputs $channel [appendArgs "yes (" $version ")\n"] + } else { + # + # NOTE: The Tcl library is ready; however, we have no idea what + # version it actually is; therefore, skip adding the test + # constraint to indicate that a specific version of Tcl + # is "either ready or available". + # + tputs $channel yes\n + } } else { + # + # NOTE: The Tcl library is not ready; however, we still need to add + # the appropriate test constraint to indicate that a specific + # version of Tcl is "either ready or available". + # + if {[haveConstraint tclLibrary86]} then { + addConstraint tclReadyOrLibrary86 + } elseif {[haveConstraint tclLibrary85]} then { + addConstraint tclReadyOrLibrary85 + } elseif {[haveConstraint tclLibrary84]} then { + addConstraint tclReadyOrLibrary84 + } + tputs $channel no\n } } proc checkForTclShell { channel } { @@ -2221,23 +2312,24 @@ # caught during [exec] (i.e. the native Tcl shell could not be # executed). # set prefix "---- checking for Tcl shell version... " - if {[catch {getTclVersionForTclShell} result] == 0 && \ - $result ne "error"} then { + if {[catch {getTclVersionForTclShell} version] == 0 && \ + $version ne "error"} then { # # NOTE: Yes, a native Tcl shell appears to be available. # addConstraint tclShell # # NOTE: Now, add the version specific test constraint. # - addConstraint [appendArgs tclShell [string map [list . ""] $result]] + addConstraint [appendArgs \ + tclShell [string map [list . ""] $version]] - tputs $channel [appendArgs $prefix "yes (" $result ")\n"] + tputs $channel [appendArgs $prefix "yes (" $version ")\n"] } else { tputs $channel [appendArgs $prefix no\n] } } @@ -2248,18 +2340,18 @@ # would indicate an error was caught during [exec] (i.e. the # native Tcl shell could not be executed). # set prefix "---- checking for Tk package version... " - if {[catch {getTkVersionForTclShell} result] == 0 && \ - $result ne "error"} then { + if {[catch {getTkVersionForTclShell} version] == 0 && \ + $version ne "error"} then { # # NOTE: Yes, a native Tk package appears to be available. # addConstraint tkPackage - tputs $channel [appendArgs $prefix "yes (" $result ")\n"] + tputs $channel [appendArgs $prefix "yes (" $version ")\n"] } else { tputs $channel [appendArgs $prefix no\n] } } @@ -2498,10 +2590,11 @@ $name . [join [lrange [split $version .] 0 1] .]] } else { set nativeUtility $name } + addConstraint nativeUtility addConstraint [appendArgs nativeUtility. $nativeUtility] tputs $channel [appendArgs $::eagle_platform(nativeUtility) \ " " ( $nativeUtility ) \n] } else { @@ -2541,16 +2634,31 @@ if {[string is integer -strict $release] && $release >= 378389} then { # # NOTE: Yes, it appears that it is available. # - addConstraint dotNet45 + addConstraint dotNet45OrHigher + + # + # NOTE: If the "release" value is greater than or equal to 378758, + # then the .NET Framework 4.5.1 is installed. + # + if {$release >= 378758} then { + addConstraint dotNet451 + addConstraint dotNet451OrHigher + + set version 4.5.1 + } else { + addConstraint dotNet45 + + set version 4.5 + } # # NOTE: Show the "release" value we found in the registry. # - tputs $channel [appendArgs "yes (" $release ")\n"] + tputs $channel [appendArgs "yes (" $release ", " $version ")\n"] # # NOTE: We are done here, return now. # return @@ -2581,11 +2689,11 @@ # # NOTE: The versions of Visual Studio that we support. # set versions [list [list 8.0 2005] [list 9.0 2008] \ - [list 10.0 2010] [list 11.0 2012]] + [list 10.0 2010] [list 11.0 2012] [list 12.0 2013]] # # NOTE: Check each version and keep track of the ones we find. # foreach version $versions { @@ -2747,11 +2855,11 @@ checkForShell checkForDebug checkForTk checkForVersion \ checkForCommand checkForTestExec checkForTestMachine \ checkForTestPlatform checkForTestConfiguration checkForTestSuffix \ checkForFile checkForPathFile checkForNativeCode checkForTip127 \ checkForTip194 checkForTip241 checkForTip285 checkForTip405 \ - checkForTip426 checkForTiming checkForPerformance \ + checkForTip426 checkForTiming checkForPerformance checkForBigLists \ checkForStackIntensive checkForInteractive checkForInteractiveCommand \ checkForUserInteraction checkForNetwork checkForCompileOption] false \ false ########################################################################### Index: Externals/Eagle/lib/Test1.0/prologue.eagle ================================================================== --- Externals/Eagle/lib/Test1.0/prologue.eagle +++ Externals/Eagle/lib/Test1.0/prologue.eagle @@ -93,12 +93,12 @@ # if {![info exists root_path] && \ ![info exists no(exec)] && ![info exists no(fossil)]} then { set pattern {^local-root:\s+(.*?)\s+$} - if {[catch {set exec [exec -- fossil info]}] || \ - [regexp -line -- $pattern $exec dummy directory] == 0} then { + if {[catch {exec -- fossil info} exec] || \ + ![regexp -line -- $pattern $exec dummy directory]} then { # # NOTE: We could not query local root directory of the source checkout # from Fossil; therefore, attempt to make an educated guess. This # value will probably be wrong for any project(s) other than Eagle. # In that case, this value should be overridden by that project to @@ -376,39 +376,10 @@ # if {![info exists test_configuration]} then { set test_configuration [getPlatformInfo configuration Release] } - # - # NOTE: Set the Tcl shell executable to use for those specialized tests that - # may require it, if necessary. - # - if {![info exists test_tclsh]} then { - # - # NOTE: When running in Eagle, more complex logic is required to determine - # the Tcl shell to use for the various tests that require it. Also, - # this same logic is used with Tcl when it is not running from an - # instance of the Tcl shell executable. - # - if {[isEagle] || ![string match tclsh* $bin_file]} then { - if {[info exists test_flags(-tclsh)] && \ - [string length $test_flags(-tclsh)] > 0} then { - # - # NOTE: Use the Tcl shell specified via the command line. - # - set test_tclsh $test_flags(-tclsh) - } else { - # - # NOTE: Check for a Tcl shell specified via the environment. - # - set test_tclsh [getTclShellFileName] - } - } else { - set test_tclsh $bin_file - } - } - # # NOTE: Has automatic log file naming been disabled? # if {![info exists no(logFileName)]} then { # @@ -417,10 +388,54 @@ if {![info exists test_log]} then { set test_log [file join [getTemporaryPath] [appendArgs [file tail [info \ nameofexecutable]] [getTestLogId] .test. [pid] .log]] } } + + # + # NOTE: Has native Tcl shell detection and use been disabled? + # + if {![info exists no(tclsh)]} then { + # + # NOTE: Set the Tcl shell executable to use for those specialized + # tests that may require it, if necessary. + # + if {![info exists test_tclsh]} then { + # + # NOTE: When running in Eagle, more complex logic is required to + # determine the Tcl shell to use for the various tests that + # require it. Also, this same logic is used with Tcl when it + # is not running from an instance of the Tcl shell executable. + # + if {[isEagle] || ![string match tclsh* $bin_file]} then { + if {[info exists test_flags(-tclsh)] && \ + [string length $test_flags(-tclsh)] > 0} then { + # + # NOTE: Use the Tcl shell specified via the command line. + # + set test_tclsh $test_flags(-tclsh) + } else { + if {![info exists no(getTclShellFileName)]} then { + # + # NOTE: Attempt to automatically select a Tcl shell to use. + # + tputs $test_channel \ + "==== WARNING: attempting automatic Tcl shell selection...\n" + + set test_tclsh [getTclShellFileName true] + } else { + # + # NOTE: Skip detection and use the fallback default. + # + set test_tclsh tclsh + } + } + } else { + set test_tclsh $bin_file + } + } + } # # NOTE: When running in Eagle, check for any non-core plugins loaded into # the interpreter and issue warnings if any are found. The warning # may be used to explain subsequent test failures due to the extra @@ -539,12 +554,12 @@ # 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 [appendArgs \ - "==== WARNING: running without any strong name signature...\n"] + 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). @@ -693,12 +708,13 @@ [pwd] \"\n] tputs $test_channel [appendArgs "---- temporary files stored in: \"" \ [getTemporaryPath] \"\n] - tputs $test_channel [appendArgs "---- native Tcl shell: \"" \ - $test_tclsh \"\n] + tputs $test_channel [appendArgs "---- native Tcl shell: " \ + [expr {[info exists test_tclsh] && [string length $test_tclsh] > 0 ? \ + [appendArgs \" $test_tclsh \"] : ""}] \n] tputs $test_channel [appendArgs "---- disabled options: " \ [formatList [lsort [array names no]] ] \n] # @@ -776,11 +792,11 @@ # # NOTE: Check the variant and/or version of the CLR that we are # currently running on. # - if {![info exists no(runtimeVersion)]} then { + if {![info exists no(checkForRuntimeVersion)]} then { checkForRuntimeVersion $test_channel } # # NOTE: Check the framework version (i.e. regardless of runtime) that @@ -1858,11 +1874,11 @@ # # NOTE: Has dedicated test support been enabled (at compile-time)? # if {![info exists no(compileTest)]} then { # - # NOTE: For test "tclLoad-1.16.1". + # NOTE: For tests "tclLoad-1.17.1" and "tclLoad-1.17.2". # checkForCompileOption $test_channel TEST } } @@ -2147,11 +2163,15 @@ if {![info exists no(tclOptions)]} then { checkForTclOptions $test_channel } - if {![info exists no(stackIntensive)]} then { + if {![info exists no(checkForBigLists)]} then { + checkForBigLists $test_channel + } + + if {![info exists no(checkForStackIntensive)]} then { checkForStackIntensive $test_channel } if {![info exists no(windowsCommandProcessor)]} then { checkForWindowsCommandProcessor $test_channel cmd.exe @@ -2263,11 +2283,11 @@ } # # NOTE: Has performance testing been disabled? # - if {![info exists no(performance)]} then { + if {![info exists no(checkForPerformance)]} then { checkForPerformance $test_channel } # # NOTE: Have any timing related constraints been disabled? @@ -2382,23 +2402,23 @@ # NOTE: Get the source checkout and tags (i.e. of Eagle or whatever # project the Eagle binaries are being used by) using a Fossil # binary in the PATH, if available. # if {![info exists no(exec)] && ![info exists no(fossil)]} then { - if {[catch {set exec [exec -- fossil info]}] == 0} then { + if {[catch {exec -- fossil info} exec] == 0} then { set pattern {^checkout:\s+(.*?)\s+$} - if {[regexp -line -- $pattern $exec dummy checkout] == 0} then { + if {![regexp -line -- $pattern $exec dummy checkout]} then { # # NOTE: We could not query the source checkout from Fossil. # set checkout } set pattern {^tags:\s+(.*?)\s+$} - if {[regexp -line -- $pattern $exec dummy tags] == 0} then { + if {![regexp -line -- $pattern $exec dummy tags]} then { # # NOTE: We could not query the tags from Fossil. # set tags } Index: SQLite.Interop/src/win/interop.h ================================================================== --- SQLite.Interop/src/win/interop.h +++ SQLite.Interop/src/win/interop.h @@ -8,11 +8,11 @@ #ifndef INTEROP_VERSION #define INTEROP_VERSION "1.0.90.0" #endif #ifndef INTEROP_SOURCE_ID -#define INTEROP_SOURCE_ID "0000000000000000000000000000000000000000" +#define INTEROP_SOURCE_ID "07ecc4ebfa97eddd155df718c73523746b853a0d" #endif #ifndef INTEROP_SOURCE_TIMESTAMP -#define INTEROP_SOURCE_TIMESTAMP "0000-00-00 00:00:00 UTC" +#define INTEROP_SOURCE_TIMESTAMP "2013-11-27 02:15:17 UTC" #endif Index: System.Data.SQLite/SQLitePatchLevel.cs ================================================================== --- System.Data.SQLite/SQLitePatchLevel.cs +++ System.Data.SQLite/SQLitePatchLevel.cs @@ -7,10 +7,10 @@ using System.Data.SQLite; /////////////////////////////////////////////////////////////////////////////// -[assembly: AssemblySourceId(null)] +[assembly: AssemblySourceId("07ecc4ebfa97eddd155df718c73523746b853a0d")] /////////////////////////////////////////////////////////////////////////////// -[assembly: AssemblySourceTimeStamp(null)] +[assembly: AssemblySourceTimeStamp("2013-11-27 02:15:17 UTC")]