test/bc_common.tcl

   1
   2
   3
   4 proc bc_find_binaries {zCaption} {
   5   # Search for binaries to test against. Any executable files that match
   6   # our naming convention are assumed to be testfixture binaries to test
   7   # against.
   8   #
   9   set binaries [list]
  10   set self [info nameofexec]
  11   set pattern "$self?*"
  12   if {$::tcl_platform(platform)=="windows"} {
  13     set pattern [string map {\.exe {}} $pattern]
  14   }
  15   foreach file [glob -nocomplain $pattern] {
  16     if {$file==$self} continue
  17     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 stdout
  28     puts "version [get_version $bin]"
  29   }
  30
  31   set ::BC(binaries) $binaries
  32   return $binaries
  33 }
  34
  35 proc get_version {binary} {
  36   set chan [launch_testfixture $binary]
  37   set v [testfixture $chan { sqlite3 -version }]
  38   close $chan
  39   set v
  40 }
  41
  42 proc do_bc_test {bin script} {
  43
  44   forcedelete test.db
  45   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 $bin
  56   regsub {.*testfixture\.} $bintag {} bintag
  57   set bintag [string map {\.exe {}} $bintag]
  58   if {$bintag == ""} {set bintag self}
  59   set saved_prefix $::testprefix
  60   append ::testprefix ".$bintag"
  61
  62   uplevel $script
  63
  64   set ::testprefix $saved_prefix
  65
  66   catch { code1 { db close } }
  67   catch { code2 { db close } }
  68   catch { close $::bc_chan }
  69 }
  70
  71 proc do_all_bc_test {script} {
  72   foreach bin $::BC(binaries) {
  73     uplevel [list do_bc_test $bin $script]
  74   }
  75 }