AryaWu/sqlite

1 2 3 4proc bc_find_binaries {zCaption} {5  # Search for binaries to test against. Any executable files that match6  # our naming convention are assumed to be testfixture binaries to test7  # against.8  #9  set binaries [list]10  set self [info nameofexec]11  set pattern "$self?*"12  if {$::tcl_platform(platform) eq "windows"} {13    set pattern [string map {\.exe {}} $pattern]14  }15  foreach file [glob -nocomplain $pattern] {16    if {$file==$self} continue17    if {[file executable $file] && [file isfile $file]} {lappend binaries $file}18  }19 20  if {[llength $binaries]==0} {21    puts "WARNING: No historical binaries to test against."22    puts "WARNING: Omitting backwards-compatibility tests"23  }24 25  foreach bin $binaries {26    puts -nonewline "Testing against $bin - "27    flush stdout28    puts "version [get_version $bin]"29  }30 31  set ::BC(binaries) $binaries32  return $binaries33}34 35proc get_version {binary} {36  set chan [launch_testfixture $binary]37  set v [testfixture $chan { sqlite3 -version }]38  close $chan39  set v40}41 42proc do_bc_test {bin script} {43 44  forcedelete test.db45  set ::bc_chan [launch_testfixture $bin]46 47  proc code1 {tcl} { uplevel #0 $tcl }48  proc code2 {tcl} { testfixture $::bc_chan $tcl }49  proc sql1 sql { code1 [list db eval $sql] }50  proc sql2 sql { code2 [list db eval $sql] }51 52  code1 { sqlite3 db test.db }53  code2 { sqlite3 db test.db }54 55  set bintag $bin56  regsub {.*testfixture\.} $bintag {} bintag57  set bintag [string map {\.exe {}} $bintag]58  if {$bintag == ""} {set bintag self}59  set saved_prefix $::testprefix60  append ::testprefix ".$bintag"61 62  uplevel $script63 64  set ::testprefix $saved_prefix65 66  catch { code1 { db close } }67  catch { code2 { db close } }68  catch { close $::bc_chan }69}70 71proc do_all_bc_test {script} {72  foreach bin $::BC(binaries) {73    uplevel [list do_bc_test $bin $script]74  }75}76