###############################################################################
#
# common.eagle --
#
# Written by Joe Mistachkin.
# Released to the public domain, use at your own risk!
#
###############################################################################
#
# NOTE: Use our own namespace here because even though we do not directly
# support namespaces ourselves, we do not want to pollute the global
# namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::Eagle {
if {[isEagle]} then {
###########################################################################
############################ BEGIN Eagle ONLY #############################
###########################################################################
proc getBuildYear {} {
#
# NOTE: See if the "year" setting has been overridden by the user (e.g.
# on the command line). This helps control exactly which set of
# binaries we are testing, those produced using the Visual Studio
# 2005, 2008, 2010, or 2012 build systems. To override this value
# via the command line, enter a command similar to one of the
# following (all on one line):
#
# EagleShell.exe -preInitialize "set test_year 2005"
# -file .\path\to\all.eagle
#
# EagleShell.exe -preInitialize "set test_year 2008"
# -file .\path\to\all.eagle
#
# EagleShell.exe -preInitialize "set test_year 2010"
# -file .\path\to\all.eagle
#
# EagleShell.exe -preInitialize "set test_year 2012"
# -file .\path\to\all.eagle
#
# EagleShell.exe -preInitialize "unset -nocomplain test_year"
# -file .\path\to\all.eagle
#
if {[info exists ::test_year] && [string length $::test_year] > 0} then {
#
# NOTE: Use the specified test year. If this variable is not set, the
# default value will be based on whether or not Eagle has been
# compiled against the CLR v2.0 or CLR v4.0.
#
return $::test_year
} else {
#
# NOTE: If Eagle has been compiled against the CLR v4.0, use "2010" by
# default (we could use "2012" in that case as well) as the test
# year; otherwise, use "2008" by default (we could use "2005" in
# that case as well). If another major [incompatible] version of
# the CLR is released, this check will have to be changed. The
# default test year to use for a particular CLR version may be
# overridden by setting the global variable "test_year_clr_v$X",
# where "$X" may [currently] be either "2" or "4".
#
if {[haveConstraint imageRuntime40]} then {
if {[info exists ::test_year_clr_v4] && \
[string length $::test_year_clr_v4] > 0} then {
#
# NOTE: Use the specified test year for the CLR v4.0.
#
return $::test_year_clr_v4
} else {
#
# NOTE: Use the default test year for the CLR v4.0.
#
return 2010; # TODO: Good "fallback" default?
}
} else {
if {[info exists ::test_year_clr_v2] && \
[string length $::test_year_clr_v2] > 0} then {
#
# NOTE: Use the specified test year for the CLR v2.0.
#
return $::test_year_clr_v2
} else {
#
# NOTE: Use the default test year for the CLR v2.0.
#
return 2008; # TODO: Good "fallback" default?
}
}
}
}
proc getBuildConfiguration {} {
#
# NOTE: See if the "configuration" setting has been overridden by the user
# (e.g. on the command line). This helps control exactly which set
# of binaries we are testing (i.e. those built in the "Debug" or
# "Release" build configurations). To override this value via the
# command line, enter a command similar to one of the following (all
# on one line):
#
# EagleShell.exe -preInitialize "set test_configuration Debug"
# -file .\path\to\all.eagle
#
# EagleShell.exe -preInitialize "set test_configuration Release"
# -file .\path\to\all.eagle
#
# EagleShell.exe -file .\path\to\all.eagle -preTest
# "unset -nocomplain test_configuration"
#
if {[info exists ::test_configuration] && \
[string length $::test_configuration] > 0} then {
#
# NOTE: Use the specified test configuration. The default value used
# for this variable is "Release", as set by the test suite itself.
#
return $::test_configuration
} else {
#
# NOTE: Normally, we will never hit this case because the value of the
# test configuration variable is always set by the test suite
# itself; however, it can be overridden using the unset command
# from the -preTest option to the test suite.
#
return $::eagle_platform(configuration)
}
}
proc getBuildDirectory {} {
#
# NOTE: See if the "native" runtime option has been set. If so, use the
# directory for the mixed-mode assembly (a.k.a. the native interop
# assembly). To enable this option via the command line, enter a
# command similar to one of the following (all on one line):
#
# EagleShell.exe -initialize -runtimeOption native
# -file .\path\to\all.eagle
#
# To enable this option via the command line prior to the "beta 16"
# release of Eagle, the following command must be used instead
# (also all on one line):
#
# EagleShell.exe -initialize -postInitialize
# "object invoke Interpreter.GetActive AddRuntimeOption native"
# -file .\path\to\all.eagle
#
if {[info exists ::build_directory] && \
[string length $::build_directory] > 0} then {
#
# NOTE: The location of the build directory has been overridden;
# therefore, use it verbatim.
#
return $::build_directory
} else {
#
# NOTE: Figure out the build base directory. This will be the directory
# that contains the actual build output directory (e.g. "bin").
#
if {[info exists ::build_base_directory] && \
[string length $::build_base_directory] > 0} then {
#
# NOTE: The location of the build base directory has been overridden;
# therefore, use it verbatim.
#
set path $::build_base_directory
} elseif {[info exists ::common_directory] && \
[string length $::common_directory] > 0} then {
#
# NOTE: Next, fallback to the parent directory of the one containing
# this file (i.e. "common.eagle"), if available.
#
set path [file dirname $::common_directory]
} else {
#
# NOTE: Finally, fallback to the parent directory of the EagleTest
# path. The EagleTest package guarantees that this variable
# will be set to the directory containing the first file to
# execute the [runTestPrologue] script library procedure.
#
set path [file dirname $::path]
}
#
# NOTE: If the "native" runtime option is set, the mixed-mode assembly
# is being tested. In that case, the path to the build directory
# will contain the platform name and all the binaries under test
# should be present in that directory. If the "native" runtime
# option is not set, the build directory will be considered to be
# "platform-neutral", with the notable exception of any native
# assembly (e.g. "SQLite.Interop.dll") copied there during the
# build process itself. If the build process somehow does not
# copy the native assembly for this platform, most of the tests
# in the suite will simply be skipped. Generally speaking, there
# are two ways to build the binaries when preparing to run the
# test suite:
#
# 1. Build the separate managed and native assemblies using some
# commands similar to:
#
# build.bat ${Configuration}ManagedOnly ${Platform}
# build.bat ${Configuration}NativeOnly ${Platform}
#
# Where ${Configuration} is either "Debug" or "Release" and
# ${Platform} is either "Win32" or "x64".
#
# 2. Build the mixed-mode assembly using a command similar to:
#
# build.bat ${Configuration} ${Platform}
#
# Where ${Configuration} is either "Debug" or "Release" and
# ${Platform} is either "Win32" or "x64". If this command is
# used, various tests that require supplementary managed
# assemblies (e.g. LINQ) may be skipped unless those binaries
# are subsequently copied into the correct directory (i.e. by
# "test_all.bat").
#
# Note that all of the build commands above will default to using
# the latest version of MSBuild available and the "test_year" may
# need to be adjusted accordingly to actually run the test suite.
# Refer to the comments in [getBuildYear] for more information on
# how to set this variable.
#
if {[hasRuntimeOption native]} then {
return [file join $path bin [getBuildYear] [machineToPlatform \
$::tcl_platform(machine)] [getBuildConfiguration]]
} else {
return [file join $path bin [getBuildYear] [getBuildConfiguration] \
bin]
}
}
}
proc getBuildFileName { fileName } {
#
# NOTE: Returns the specified file name as if it were located in the
# build directory, discarding any directory information present
# in the file name as provided by our caller.
#
return [file nativename \
[file join [getBuildDirectory] [file tail $fileName]]]
}
proc getBinaryDirectory {} {
#
# NOTE: This procedure returns the directory where the test application
# itself (i.e. the Eagle shell) is located. This will be used as
# the destination for the copied System.Data.SQLite native and
# managed assemblies (i.e. because this is one of the few places
# where the CLR will actually find and load them properly).
#
if {[info exists ::binary_directory] && \
[string length $::binary_directory] > 0} then {
#
# NOTE: The location of the binary directory has been overridden;
# therefore, use it verbatim.
#
return $::binary_directory
} else {
return [info binary]
}
}
proc getBinaryFileName { fileName } {
#
# NOTE: Returns the specified file name as if it were located in the
# binary directory, discarding any directory information present
# in the file name as provided by our caller.
#
return [file nativename \
[file join [getBinaryDirectory] [file tail $fileName]]]
}
proc getCoreBinaryFileName { {standard false} } {
#
# NOTE: Returns the full path for the file containing the core SQLite
# library code for this platform.
#
if {[hasRuntimeOption native]} then {
#
# NOTE: Return the mixed-mode assembly file name.
#
return [file nativename \
[file join [getBinaryDirectory] System.Data.SQLite.dll]]
} elseif {$standard} then {
#
# NOTE: Return the native-only standard SQLite library file name.
#
return [file nativename \
[file join [getBinaryDirectory] sqlite3.dll]]
} else {
#
# NOTE: Return the native-only interop assembly file name.
#
return [file nativename \
[file join [getBinaryDirectory] SQLite.Interop.dll]]
}
}
proc getDatabaseDirectory {} {
#
# NOTE: This procedure returns the directory where the test databases
# should be located. By default, this just uses the temporary
# directory configured for this system.
#
if {[info exists ::database_directory] && \
[string length $::database_directory] > 0} then {
#
# NOTE: The location of the database directory has been overridden;
# therefore, use it.
#
return [file normalize $::database_directory]
} else {
return [getTemporaryPath]
}
}
proc getTemporaryDirectory {} {
#
# NOTE: This procedure returns the directory where the temporary files
# should be located. By default, this just uses the temporary
# directory configured for this system.
#
if {[info exists ::temporary_directory] && \
[string length $::temporary_directory] > 0} then {
#
# NOTE: The location of the temporary directory has been overridden;
# therefore, use it.
#
return [file normalize $::temporary_directory]
} else {
return [getTemporaryPath]
}
}
proc getTestOverridesPreamble { {extraVarNames ""} } {
set varNames [list]
#
# NOTE: If available, start with the master list of test override
# variables.
#
if {[info exists ::test_overrides] && \
[llength $::test_overrides] > 0} then {
eval lappend varNames $::test_overrides
}
#
# NOTE: If requested by our caller, add any additional variable
# names to copy now.
#
if {[llength $extraVarNames] > 0} then {
eval lappend varNames $extraVarNames
}
#
# NOTE: Build the script fragment to be returned by processing each
# variable name and adding the nececessary script fragments for
# each one.
#
set result ""
foreach varName $varNames {
#
# NOTE: Build the qualified global variable name.
#
set fullVarName [appendArgs :: $varName]
#
# NOTE: Does the variable exist in this interpreter context?
#
if {[info exists $fullVarName]} then {
#
# NOTE: Append a script fragment to the result that will correctly
# copy any contained value to another interpreter context.
#
append result \n "set " $fullVarName " \{" [set $fullVarName] \}
}
}
#
# NOTE: If the result contains one or more script fragments, append a
# newline.
#
if {[string length $result] > 0} then {
append result \n
}
return $result
}
proc getAppDomainPreamble { {prefix ""} {suffix ""} } {
#
# NOTE: This procedure returns a test setup script fragment suitable for
# evaluation by an interpreter created in an isolated application
# domain. The script fragment being returned will be surrounded by
# the prefix and suffix "script fragments" specified by our caller,
# if any. The entire script being returned will be substituted via
# [subst], in the context of our caller, before being returned.
# This step is necessary so that some limited context information,
# primarily related to the testing directories, can be transferred
# to the interpreter in the isolated application domain, making it
# able to successfully run tests that require one or more of the
# files in one of the testing directories. Callers should keep in
# mind that the test script fragment being returned cannot rely on
# any script library procedures that are not provided by the Eagle
# library package (i.e. "init.eagle"), including those provided by
# the Eagle test package, unless the file containing them is loaded
# manually via some other mechanism (e.g. by including appropriate
# [package require] or [source] commands in the prefix or suffix
# script fragments). Also, all variable references and all nested
# commands (i.e. those in square brackets) contained in the final
# script fragment will end up being evaluated in the context of the
# calling interpreter and not the target interpreter created in the
# isolated application domain unless the dollar signs and/or square
# brackets are specially quoted with backslashes.
#
return [uplevel 1 [list subst [appendArgs $prefix {
if {[hasRuntimeOption native]} then {
object invoke Interpreter.GetActive AddRuntimeOption native
}
} [getTestOverridesPreamble [list path test_channel]] $suffix]]]
}
proc tryCopyBuildFile { fileName } {
#
# NOTE: If we cannot copy the assembly then it is probably already loaded.
#
set sourceFileName [getBuildFileName $fileName]
if {![file exists $sourceFileName]} then {
tputs $::test_channel [appendArgs \
"---- skipped copying build file \"" $sourceFileName \
"\", it does not exist\n"]
return
}
set targetFileName [getBinaryFileName $fileName]
if {[catch {
file copy -force $sourceFileName $targetFileName}] == 0} then {
tputs $::test_channel [appendArgs \
"---- copied build file from \"" $sourceFileName "\" to \"" \
$targetFileName \"\n]
} else {
tputs $::test_channel [appendArgs \
"---- failed to copy build file from \"" $sourceFileName \
"\" to \"" $targetFileName \"\n]
}
}
proc tryDeleteBinaryFile { fileName } {
set fileName [getBinaryFileName $fileName]
if {![file exists $fileName]} then {
tputs $::test_channel [appendArgs \
"---- skipped deleting binary file \"" $fileName \
"\", it does not exist\n"]
return
}
if {[catch {file delete $fileName}] == 0} then {
tputs $::test_channel [appendArgs \
"---- deleted binary file \"" $fileName \"\n]
} else {
tputs $::test_channel [appendArgs \
"---- failed to delete binary file \"" $fileName \"\n]
}
}
proc tryCopyAssembly { fileName {pdb true} } {
tryCopyBuildFile $fileName
if {$pdb} then {
tryCopyBuildFile [appendArgs [file rootname $fileName] .pdb]
}
}
proc tryDeleteAssembly { fileName {pdb true} } {
tryDeleteBinaryFile $fileName
if {$pdb} then {
tryDeleteBinaryFile [appendArgs [file rootname $fileName] .pdb]
}
}
proc tryLoadAssembly { fileName } {
set fileName [getBinaryFileName $fileName]
if {[catch {set assembly \
[object load -loadtype File -alias $fileName]}] == 0} then {
#
# NOTE: Now, add the necessary test constraint.
#
addConstraint [file rootname [file tail $fileName]]
#
# NOTE: Grab the image runtime version from the assembly because
# several tests rely on it having a certain value.
#
addConstraint [appendArgs [file tail $fileName] _ \
[$assembly ImageRuntimeVersion]]
#
# NOTE: Return the full path of the loaded file.
#
return $fileName
}
return ""
}
proc checkForSQLite { channel } {
tputs $channel "---- checking for core SQLite library... "
if {[catch {
object invoke -flags +NonPublic System.Data.SQLite.SQLite3 \
SQLiteVersion} version] == 0} then {
#
# NOTE: Attempt to query the Fossil source identifier for the SQLite
# core library.
#
if {[catch {
object invoke -flags +NonPublic System.Data.SQLite.SQLite3 \
SQLiteSourceId} sourceId]} then {
#
# NOTE: We failed to query the Fossil source identifier.
#
set sourceId unknown
}
#
# NOTE: Yes, the SQLite core library appears to be available.
#
addConstraint SQLite
tputs $channel [appendArgs "yes (" $version " " $sourceId ")\n"]
} else {
tputs $channel no\n
}
}
proc checkForSQLiteDefineConstant { channel name } {
tputs $channel [appendArgs \
"---- checking for System.Data.SQLite define constant \"" $name \
"\"... "]
if {[catch {
object invoke -flags +NonPublic System.Data.SQLite.SQLite3 \
DefineConstants} defineConstants] == 0} then {
if {[lsearch -exact -nocase $defineConstants $name] != -1} then {
#
# NOTE: Yes, this define constant was enabled when the managed
# assembly was compiled.
#
addConstraint [appendArgs defineConstant.System.Data.SQLite. $name]
tputs $channel yes\n
} else {
tputs $channel no\n
}
} else {
tputs $channel error\n
}
}
proc getDateTimeFormat {} {
#
# NOTE: This procedure simply returns the "default" DateTime format used
# by the test suite.
#
if {[info exists ::datetime_format] && \
[string length $::datetime_format] > 0} then {
#
# NOTE: Return the manually overridden value for the DateTime format.
#
return $::datetime_format
} else {
#
# NOTE: Return an ISO8601 DateTime format compatible with SQLite,
# System.Data.SQLite, and suitable for round-tripping with the
# DateTime class of the framework. If this value is changed,
# various tests may fail.
#
return "yyyy-MM-dd HH:mm:ss.FFFFFFFK"
}
}
proc enumerableToList { enumerable } {
set result [list]
if {[string length $enumerable] == 0 || $enumerable eq "null"} then {
return $result
}
object foreach -alias item $enumerable {
if {[string length $item] > 0} then {
lappend result [$item ToString]
}
}
return $result
}
proc catchAndReturn { script {stackTrace false} {strict true} } {
#
# NOTE: Evaluate the script provided by our caller in their context,
# capturing both the result and the return code.
#
set code [catch {uplevel 1 $script} result]
#
# NOTE: Did the script provided by our caller NOT raise an error?
#
if {$strict && $code == 0 || !$strict && $code != 1} then {
#
# NOTE: Success. Return a list with the return code and the result.
#
return [list $code $result]
} elseif {$stackTrace} then {
#
# NOTE: Failure. Our caller wants a full stack trace (if applicable),
# return a list with the return code and the result verbatim.
#
return [list $code $result]
} else {
#
# NOTE: Failure. Our caller does not want a full stack trace (if
# applicable), return a list with the return code, the error
# code for the interpreter, and the error message up to the
# point where the stack trace should start.
#
set index [string first " at " $result]; # HACK: Reliable?
return [list $code $::errorCode [expr {$index != -1 ? \
[string trim [string range $result 0 $index]] : $result}]]
}
}
proc compileCSharpWith {
text memory symbols strict resultsVarName errorsVarName fileNames
args } {
#
# NOTE: Since we are going to use this method name a lot, assign it to a
# variable first.
#
set add ReferencedAssemblies.Add
#
# NOTE: Create the base command to evaluate and add the property settings
# that are almost always needed by our unit tests (i.e. the System
# and System.Data assembly references).
#
set command [list compileCSharp $text $memory $symbols $strict results \
errors $add System.dll $add System.Data.dll $add System.Xml.dll]
#
# NOTE: Add all the provided file names as assembly references.
#
foreach fileName $fileNames {
lappend command $add [getBinaryFileName $fileName]
}
#
# NOTE: Add the extra arguments, if any, to the command to evaluate.
#
eval lappend command $args
#
# NOTE: Alias the compiler local results and errors variables to the
# variable names provided by our caller.
#
upvar 1 $resultsVarName results
upvar 1 $errorsVarName errors
#
# NOTE: Evaluate the constructed [compileCSharp] command and return the
# result.
#
eval $command
}
proc isMemoryDb { fileName } {
#
# NOTE: Is the specified database file name really an in-memory database?
#
return [expr {$fileName eq ":memory:" || \
[string range $fileName 0 12] eq "file::memory:"}]
}
proc executeSql { sql {execute none} {fileName ""} } {
if {[string length $fileName] == 0} then {set fileName :memory:}
setupDb $fileName "" "" "" "" "" false false false false memDb
try {
return [sql execute -execute $execute $memDb $sql]
} finally {
cleanupDb $fileName memDb false false
}
}
proc setupDb {
fileName {mode ""} {dateTimeFormat ""} {dateTimeKind ""} {flags ""}
{extra ""} {qualify true} {delete true} {uri false}
{temporary true} {varName db} } {
#
# NOTE: First, see if our caller has requested an in-memory database.
#
set isMemory [isMemoryDb $fileName]
#
# NOTE: For now, all test databases used by the test suite are placed into
# the temporary directory. Each database used by a test should be
# cleaned up by that test using the "cleanupDb" procedure, below.
#
if {!$isMemory && $qualify} then {
set fileName [file join [getDatabaseDirectory] [file tail $fileName]]
}
#
# NOTE: By default, delete any pre-existing database with the same file
# name if it currently exists.
#
if {!$isMemory && $delete && [file exists $fileName]} then {
#
# NOTE: Attempt to delete any pre-existing database with the same file
# name.
#
if {[catch {file delete $fileName} error]} then {
#
# NOTE: We somehow failed to delete the file, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to delete database file \"" $fileName \
"\" during setup, error: " \n\t $error \n]
}
}
#
# NOTE: Refer to the specified variable (e.g. "db") in the context of our
# caller. The handle to the opened database will be stored there.
#
upvar 1 $varName db
#
# NOTE: Start building the connection string. The only required portion
# of the connection string is the data source, which contains the
# database file name itself. If our caller wants to use a URI as
# the data source, use the FullUri connection string property to
# prevent the data source string from being mangled.
#
if {$uri} then {
set connection {FullUri=${fileName}}
} else {
set connection {Data Source=${fileName}}
}
#
# NOTE: Since this procedure has no special knowledge of what the default
# setting is for the ToFullPath connection string propery, always
# add the value we know about to the connection string.
#
append connection {;ToFullPath=${qualify}}
#
# NOTE: If our caller specified a journal mode, add the necessary portion
# of the connection string now.
#
if {[string length $mode] > 0} then {
append connection {;Journal Mode=${mode}}
}
#
# NOTE: If our caller specified a DateTime format, add the necessary
# portion of the connection string now.
#
if {[string length $dateTimeFormat] > 0} then {
append connection {;DateTimeFormat=${dateTimeFormat}}
}
#
# NOTE: If our caller specified a DateTimeKind, add the necessary portion
# of the connection string now.
#
if {[string length $dateTimeKind] > 0} then {
append connection {;DateTimeKind=${dateTimeKind}}
}
#
# NOTE: If there are any global (per test run) connection flags currently
# set, use them now (i.e. by combining them with the ones for this
# connection).
#
if {[info exists ::connection_flags] && \
[string length $::connection_flags] > 0} then {
#
# NOTE: Show (and log) that we detected some global connection flags.
#
tputs $::test_channel [appendArgs \
"---- global connection flags detected: " $::connection_flags \n]
#
# NOTE: Combine and/or replace the connection flags and then show the
# new value.
#
set flags [combineFlags $flags $::connection_flags]
tputs $::test_channel [appendArgs \
"---- combined connection flags are: " $flags \n]
}
#
# NOTE: If our caller specified a SQLiteConnectionFlags, add the necessary
# portion of the connection string now.
#
if {[string length $flags] > 0} then {
append connection {;Flags=${flags}}
}
#
# NOTE: If our caller specified an extra payload to the connection string,
# append it now.
#
if {[string length $extra] > 0} then {
append connection \; $extra
}
#
# NOTE: Open the database connection now, placing the opaque handle value
# into the variable specified by our caller.
#
set db [sql open -type SQLite [subst $connection]]
#
# NOTE: Configure the temporary directory for the newly opened database
# connection now unless our caller forbids it.
#
if {$temporary && ![info exists ::no(setTemporaryDirectory)]} then {
sql execute $db [appendArgs \
"PRAGMA temp_store_directory = \"" [getTemporaryDirectory] \"\;]
}
#
# NOTE: Always return the connection handle upon success.
#
return $db
}
proc getDbConnection { {varName db} } {
#
# NOTE: Refer to the specified variable (e.g. "db") in the context of our
# caller. The handle to the database previously opened by [setupDb]
# should be stored there.
#
upvar 1 $varName db
#
# NOTE: This returns the ADO.NET IDbConnection object instance for the
# specified databse handle. Since getting this object relies upon
# Eagle internals, great care should be taken to avoid disposing of
# this object or otherwise putting it into an invalid state.
#
if {[info exists db]} then {
if {[catch {
object invoke -flags +NonPublic -objectflags +NoDispose \
-alias Interpreter.GetActive.connections Item $db} \
result] == 0} then {
#
# NOTE: Success, return the opaque object handle.
#
return $result
} else {
#
# NOTE: Failure, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to get connection handle for database \"" \
$db "\", error: " \n\t $result \n]
}
}
}
proc freeDbConnection { {varName connection} } {
#
# NOTE: Refer to the specified variable (e.g. "connection") in the context
# of our caller. The opaque object handle for an ADO.NET connection
# previously returned by [getDbConnection] should be stored there.
#
upvar 1 $varName connection
#
# NOTE: Attempt to remove the opaque object handle from the interpreter
# now. This [object dispose] call will not actually dispose of the
# underlying object because the +NoDispose flag was set on it during
# creation of the opaque object handle.
#
if {[info exists connection] && \
[catch {object dispose $connection} error]} then {
#
# NOTE: We somehow failed to remove the handle, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to remove connection handle \"" $connection \
"\", error: " \n\t $error \n]
}
}
proc cleanupDb { fileName {varName db} {collect true} {qualify true}
{delete true} } {
#
# NOTE: Attempt to force all pending "garbage" objects to be collected,
# including SQLite statements and backup objects; this should allow
# the underlying database file to be deleted.
#
if {$collect} then {
collectGarbage $::test_channel
}
#
# NOTE: Refer to the specified variable (e.g. "db") in the context of our
# caller. The handle to the database previously opened by [setupDb]
# should be stored there.
#
upvar 1 $varName db
#
# NOTE: Close the connection to the database now. This should allow us to
# delete the underlying database file.
#
if {[info exists db] && [catch {sql close $db} error]} then {
#
# NOTE: We somehow failed to close the database, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to close database \"" $db "\", error: " \
\n\t $error \n]
}
#
# NOTE: First, see if our caller has requested an in-memory database.
#
set isMemory [isMemoryDb $fileName]
#
# NOTE: Build the full path to the database file name. For now, all test
# database files are stored in the temporary directory.
#
if {!$isMemory && $qualify} then {
set fileName [file join [getDatabaseDirectory] [file tail $fileName]]
}
#
# NOTE: Check if the file still exists.
#
if {!$isMemory && $delete && [file exists $fileName]} then {
#
# NOTE: Skip deleting database files if somebody sets the global
# variable to prevent it.
#
if {![info exists ::no(cleanupDbFile)]} then {
#
# NOTE: Attempt to delete the test database file now.
#
if {[set code [catch {file delete $fileName} error]]} then {
#
# NOTE: We somehow failed to delete the file, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to delete database file \"" $fileName \
"\" during cleanup, error: " \n\t $error \n]
}
} else {
#
# NOTE: Show that we skipped deleting the file.
#
set code 0
tputs $::test_channel [appendArgs \
"==== WARNING: skipped deleting database file \"" $fileName \
"\" during cleanup\n"]
}
} else {
#
# NOTE: The file does not exist, success!
#
set code 0
}
return $code
}
proc cleanupFile { fileName {collect true} {force false} } {
#
# NOTE: Attempt to force all pending "garbage" objects to be collected,
# including SQLite statements and backup objects; this should allow
# the underlying database file to be deleted.
#
if {$collect} then {
collectGarbage $::test_channel
}
#
# NOTE: Check if the file still exists.
#
if {[file exists $fileName]} then {
#
# NOTE: Skip deleting test files if somebody sets the global variable
# to prevent it.
#
if {$force || ![info exists ::no(cleanupFile)]} then {
#
# NOTE: Attempt to delete the test file now.
#
if {[set code [catch {file delete $fileName} error]]} then {
#
# NOTE: We somehow failed to delete the file, report why.
#
tputs $::test_channel [appendArgs \
"==== WARNING: failed to delete test file \"" $fileName \
"\" during cleanup, error: " \n\t $error \n]
}
} else {
#
# NOTE: Show that we skipped deleting the file.
#
set code 0
tputs $::test_channel [appendArgs \
"==== WARNING: skipped deleting test file \"" $fileName \
"\" during cleanup\n"]
}
} else {
#
# NOTE: The file does not exist, success!
#
set code 0
}
return $code
}
proc collectGarbage { channel } {
#
# NOTE: Attempt to force a full garbage collection now. Report any
# error that is encountered if we fail.
#
if {[catch {object invoke GC GetTotalMemory true} error]} then {
tputs $channel [appendArgs \
"==== WARNING: failed full garbage collection, error: " \
\n\t $error \n]
}
}
proc shutdownSQLite { channel {force false} {quiet false} } {
#
# NOTE: Make sure that SQLite core library is completely shutdown. This
# is used by tests that change configuration options and/or those
# that need to make sure logging is initialized (i.e. just in case
# the SQLite core library was initialized in the process prior to
# the SQLiteLog class being able to setup its logging callback).
#
if {$force || [haveConstraint SQLite]} then {
if {[catch {object invoke -flags +NonPublic \
System.Data.SQLite.UnsafeNativeMethods \
sqlite3_shutdown} result] == 0} then {
if {!$quiet} then {
tputs $channel [appendArgs \
"---- call sqlite3_shutdown()... ok: " $result \n]
}
} else {
if {!$quiet} then {
tputs $channel [appendArgs \
"---- call sqlite3_shutdown()... error: " \n\t $result \n]
}
}
}
}
proc reportSQLiteResources { channel {quiet false} {collect true} } {
#
# NOTE: Skip all output if we are running in "quiet" mode.
#
if {!$quiet} then {
tputs $channel "---- current memory in use by SQLite... "
}
if {[catch {object invoke -flags +NonPublic \
System.Data.SQLite.UnsafeNativeMethods \
sqlite3_memory_used} memory] == 0} then {
if {!$quiet} then {
tputs $channel [appendArgs $memory " bytes\n"]
}
} else {
#
# NOTE: Maybe the SQLite core library is unavailable?
#
set memory unknown
if {!$quiet} then {
tputs $channel [appendArgs $memory \n]
}
}
set result $memory; # NOTE: Return memory in-use to our caller.
if {!$quiet} then {
tputs $channel "---- maximum memory in use by SQLite... "
}
if {[catch {object invoke -flags +NonPublic \
System.Data.SQLite.UnsafeNativeMethods \
sqlite3_memory_highwater 0} memory] == 0} then {
if {!$quiet} then {
tputs $channel [appendArgs $memory " bytes\n"]
}
} else {
#
# NOTE: Maybe the SQLite core library is unavailable?
#
set memory unknown
if {!$quiet} then {
tputs $channel [appendArgs $memory \n]
}
}
if {$collect} then {
collectGarbage $channel
}
if {!$quiet} then {
tputs $channel "---- current memory in use by the CLR... "
}
if {[catch {object invoke GC GetTotalMemory false} memory] == 0} then {
if {[string is integer -strict $memory]} then {
if {!$quiet} then {
tputs $channel [appendArgs $memory " bytes\n"]
}
} else {
set memory invalid
if {!$quiet} then {
tputs $channel [appendArgs $memory \n]
}
}
} else {
set memory unknown
if {!$quiet} then {
tputs $channel [appendArgs $memory \n]
}
}
return $result
}
proc checkForSQLiteDirectories { channel {reset false} } {
#
# NOTE: Check if the sqlite3_win32_set_directory function is available.
#
tputs $channel \
"---- checking for function sqlite3_win32_set_directory... "
#
# NOTE: This call to the sqlite3_win32_set_directory function uses the
# invalid value 0 for the first argument. This code is designed
# to check if calling the function will raise an exception (i.e.
# the actual result of the function does not matter as long as no
# directory is changed).
#
if {[catch {
object invoke -flags +NonPublic \
System.Data.SQLite.UnsafeNativeMethods \
sqlite3_win32_set_directory 0 null}] == 0} then {
#
# NOTE: Calling the sqlite3_win32_set_directory function does not
# cause an exception; therefore, it must be available (i.e.
# even though it should return a failure return code in this
# case).
#
addConstraint sqlite3_win32_set_directory
tputs $channel yes\n
#
# NOTE: Does our caller want to reset the directories?
#
if {$reset} then {
#
# NOTE: Now make sure the database and temporary directories are
# reset their default values, which should be null for both.
# Since the sqlite3_win32_set_directory function is available,
# use it.
#
for {set index 1} {$index < 3} {incr index} {
if {[catch {
object invoke -flags +NonPublic \
System.Data.SQLite.UnsafeNativeMethods \
sqlite3_win32_set_directory $index null} \
result] == 0} then {
tputs $channel [appendArgs \
"---- call sqlite3_win32_set_directory(" $index \
", null)... ok: " $result \n]
} else {
tputs $channel [appendArgs \
"---- call sqlite3_win32_set_directory(" $index \
", null)... error: " \n\t $result \n]
}
}
}
} else {
tputs $channel no\n
#
# NOTE: Does our caller want to reset the directories?
#
if {$reset} then {
#
# NOTE: Now make sure the database and temporary directories are
# reset their default values, which should be null for both.
# Since the sqlite3_win32_set_directory function does not
# appear to be available, use the associated PRAGMA commands
# instead.
#
foreach directory [list data_store_directory temp_store_directory] {
set sql [appendArgs "PRAGMA " $directory " = \"\";"]
if {[catch {executeSql $sql} result] == 0} then {
tputs $channel [appendArgs \
"---- execute PRAGMA " $directory "... ok: " \
$result \n]
} else {
tputs $channel [appendArgs \
"---- execute PRAGMA " $directory "... error: " \
\n\t $result \n]
}
}
}
}
#
# NOTE: Finally, show the current value of the database and temporary
# directories.
#
foreach directory [list data_store_directory temp_store_directory] {
tputs $channel [appendArgs "---- checking " $directory "... "]
set sql [appendArgs "PRAGMA " $directory \;]
if {[catch {executeSql $sql scalar} result] == 0} then {
tputs $channel [appendArgs "ok: \"" $result \"\n]
} else {
tputs $channel [appendArgs "error: " \n\t $result \n]
}
}
}
proc runSQLiteTestPrologue {} {
#
# NOTE: Skip running our custom prologue if the main one has been skipped.
#
if {![info exists ::no(prologue.eagle)]} then {
#
# NOTE: Skip all System.Data.SQLite related file handling (deleting,
# copying, and loading) if we are so instructed.
#
if {![info exists ::no(sqliteFiles)]} then {
#
# NOTE: Skip trying to delete any files if we are so instructed.
#
if {![info exists ::no(deleteSqliteFiles)]} then {
tryDeleteAssembly sqlite3.dll
removeConstraint file_sqlite3.dll
tryDeleteAssembly SQLite.Interop.dll
removeConstraint file_SQLite.Interop.dll
tryDeleteAssembly System.Data.SQLite.dll
removeConstraint file_System.Data.SQLite.dll
tryDeleteAssembly System.Data.SQLite.Linq.dll
removeConstraint file_System.Data.SQLite.Linq.dll
}
#
# NOTE: Skip trying to copy any files if we are so instructed.
#
if {![info exists ::no(copySqliteFiles)]} then {
tryCopyAssembly sqlite3.dll
tryCopyAssembly SQLite.Interop.dll
tryCopyAssembly System.Data.SQLite.dll
tryCopyAssembly System.Data.SQLite.Linq.dll
}
#
# NOTE: Skip trying to load any files if we are so instructed.
#
if {![info exists ::no(loadSqliteFiles)]} then {
tryLoadAssembly System.Data.SQLite.dll
tryLoadAssembly System.Data.SQLite.Linq.dll
}
}
catch {
tputs $::test_channel [appendArgs \
"---- file version of \"sqlite3.dll\"... " \
[file version [getBinaryFileName sqlite3.dll]] \n]
}
catch {
tputs $::test_channel [appendArgs \
"---- file version of \"SQLite.Interop.dll\"... " \
[file version [getBinaryFileName SQLite.Interop.dll]] \n]
}
catch {
tputs $::test_channel [appendArgs \
"---- file version of \"System.Data.SQLite.dll\"... " \
[file version [getBinaryFileName System.Data.SQLite.dll]] \n]
}
catch {
tputs $::test_channel [appendArgs \
"---- file version of \"System.Data.SQLite.Linq.dll\"... " \
[file version [getBinaryFileName System.Data.SQLite.Linq.dll]] \n]
}
set assemblies [object invoke AppDomain.CurrentDomain GetAssemblies]
object foreach assembly $assemblies {
if {[string match \{System.Data.SQLite* $assembly]} then {
tputs $::test_channel [appendArgs \
"---- found assembly: " $assembly \n]
}
}
catch {
tputs $::test_channel \
"---- define constants for \"System.Data.SQLite\"... "
if {[catch {object invoke -flags +NonPublic \
System.Data.SQLite.SQLite3 DefineConstants} \
defineConstants] == 0} then {
tputs $::test_channel [appendArgs [formatList [lsort \
$defineConstants]] \n]
} else {
tputs $::test_channel unknown\n
}
}
#
# NOTE: Now, we need to know if the SQLite core library is available
# (i.e. because the managed-only System.Data.SQLite assembly can
# load without it; however, it cannot do anything useful without
# it). If we are using the mixed-mode assembly and we already
# found it (above), this should always succeed.
#
checkForSQLite $::test_channel
#
# NOTE: Check the SQLite database and temporary directories.
#
checkForSQLiteDirectories $::test_channel
#
# NOTE: Attempt to determine if the custom extension functions were
# compiled into the SQLite interop assembly.
#
checkForSQLiteDefineConstant $::test_channel \
CHECK_STATE
checkForSQLiteDefineConstant $::test_channel \
USE_INTEROP_DLL
checkForSQLiteDefineConstant $::test_channel \
INTEROP_EXTENSION_FUNCTIONS
checkForSQLiteDefineConstant $::test_channel \
INTEROP_TEST_EXTENSION
checkForSQLiteDefineConstant $::test_channel \
SQLITE_STANDARD
#
# NOTE: Check the current build year. Basically, this indicates
# which version of MSBuild and/or Visual Studio was used to
# compile the assembly binaries under test.
#
tputs $::test_channel \
"---- checking for System.Data.SQLite build year... "
set year [getBuildYear]
addConstraint [appendArgs buildYear $year]
tputs $::test_channel [appendArgs \" $year \"\n]
#
# NOTE: Check the current build configuration. This should normally
# be either "Debug" or "Release".
#
tputs $::test_channel \
"---- checking for System.Data.SQLite build configuration... "
set configuration [getBuildConfiguration]
addConstraint [appendArgs buildConfiguration $configuration]
tputs $::test_channel [appendArgs \" $configuration \"\n]
#
# NOTE: Check for the native runtime option, which would mean we are
# using the mixed-mode assembly.
#
checkForRuntimeOption $::test_channel native
#
# NOTE: Report the resource usage prior to running any tests.
#
reportSQLiteResources $::test_channel
#
# NOTE: Show the active test constraints.
#
tputs $::test_channel [appendArgs "---- constraints: " \
[formatList [lsort [getConstraints]]] \n]
#
# NOTE: Show when our tests actually began (now).
#
tputs $::test_channel [appendArgs \
"---- System.Data.SQLite tests began at " \
[clock format [clock seconds]] \n]
}
}
proc runSQLiteTestEpilogue {} {
#
# NOTE: Skip running our custom epilogue if the main one has been skipped.
#
if {![info exists ::no(epilogue.eagle)]} then {
#
# NOTE: Show when our tests actually ended (now).
#
tputs $::test_channel [appendArgs \
"---- System.Data.SQLite tests ended at " \
[clock format [clock seconds]] \n]
#
# NOTE: Also report the resource usage after running the tests.
#
reportSQLiteResources $::test_channel
}
}
###########################################################################
############################# END Eagle ONLY ##############################
###########################################################################
}
#
# NOTE: Save the name of the directory containing this file.
#
if {![info exists ::common_directory]} then {
set ::common_directory [file dirname [info script]]
}
#
# NOTE: Provide the System.Data.SQLite test package to the interpreter.
#
package provide System.Data.SQLite.Test 1.0
}