SQLite

# 2010 August 19
#
# The author disclaims copyright to this source code.  In place of
# a legal notice, here is a blessing:
#
#    May you do good and not evil.
#    May you find forgiveness for yourself and forgive others.
#    May you share freely, never taking more than you give.
#
#***********************************************************************
# This file implements regression tests for SQLite library.  The
# focus of this file is testing that the current version of SQLite
# is capable of reading and writing databases created by previous
# versions, and vice-versa.
#
# To use this test, old versions of the testfixture process should be
# copied into the working directory alongside the new version. The old
# versions should be named "testfixtureXXX" (or testfixtureXXX.exe on
# windows), where XXX can be any string.
#
# This test file uses the tcl code for controlling a second testfixture
# process located in lock_common.tcl. See the commments in lock_common.tcl 
# for documentation of the available commands.
#

set testdir [file dirname $argv0]
source $testdir/tester.tcl
source $testdir/lock_common.tcl
source $testdir/malloc_common.tcl

# Search for binaries to test against. Any executable files that match
# our naming convention are assumed to be testfixture binaries to test
# against.
#
set binaries [list]
set pattern "[file tail [info nameofexec]]?*"
foreach file [glob $pattern] {
  if {[file executable $file]} {lappend binaries $file}
}
if {[llength $binaries]==0} {
  puts "WARNING: No binaries to test against. No tests have been run."
  finish_test
  return
}
proc get_version {binary} {
  set chan [launch_testfixture $binary]
  set v [testfixture $chan { sqlite3 -version }]
  close $chan
  set v
}
foreach bin $binaries {
  puts "Testing against $bin - version [get_version $bin]"
}

#set binaries testfixture

proc do_backcompat_test {rv binary script} {

  if { $rv } {
    proc code1 {tcl} { testfixture $::bc_chan $tcl }
    proc code2 {tcl} { uplevel #0 $tcl }
  } else {
    proc code1 {tcl} { uplevel #0 $tcl }
    proc code2 {tcl} { testfixture $::bc_chan $tcl }
  }

  proc sql1 sql { code1 [list db eval $sql] }
  proc sql2 sql { code2 [list db eval $sql] }

  file delete -force test.db

  set ::bc_chan [launch_testfixture $binary]
  code1 { sqlite3 db test.db }
  code2 { sqlite3 db test.db }

  uplevel $script

  catch { code1 { db close } }
  catch { code2 { db close } }
  catch { close $::bc_chan }
}

array set ::incompatible [list]
proc do_allbackcompat_test {script} {

  foreach bin $::binaries {
    set nErr [set_test_counter errors]
    foreach dir {0 1} {

      set ::bcname ".$dir.[string map {testfixture {}} $bin]."

      rename do_test _do_test
      proc do_test {nm sql res} {
        set nm [regsub {\.} $nm $::bcname]
        uplevel [list _do_test $nm $sql $res]
      }

      do_backcompat_test $dir $bin $script

      rename do_test {}
      rename _do_test do_test
    }
    if { $nErr < [set_test_counter errors] } {
      set ::incompatible([get_version $bin]) 1
    }
  }
}

proc read_file {zFile} {
  set zData {}
  catch {
    set fd [open $zFile]
    fconfigure $fd -translation binary -encoding binary
    set zData [read $fd]
    close $fd
  }
  return $zData
}
proc write_file {zFile zData} {
  set fd [open $zFile w]
  fconfigure $fd -translation binary -encoding binary
  puts -nonewline $fd $zData
  close $fd
}
proc read_file_system {} {
  set ret [list]
  foreach f {test.db test.db-journal test.db-wal} { lappend ret [read_file $f] }
  set ret
}
proc write_file_system {data} {
  foreach f {test.db test.db-journal test.db-wal} d $data { 
    if {[string length $d] == 0} {
      file delete -force $f
    } else {
      write_file $f $d
    }
  }
}

#-------------------------------------------------------------------------
# Actual tests begin here.
#
do_allbackcompat_test {

  # Test that database files are backwards compatible.
  #
  do_test backcompat-1.1.1 { sql1 { 
    CREATE TABLE t1(a PRIMARY KEY, b UNIQUE);
    INSERT INTO t1 VALUES('abc', 'def');
  } } {}
  do_test backcompat-1.1.2 { sql2 { SELECT * FROM t1; } } {abc def}
  do_test backcompat-1.1.3 { sql2 { INSERT INTO t1 VALUES('ghi', 'jkl'); } } {}
  do_test backcompat-1.1.4 { sql1 { SELECT * FROM t1; } } {abc def ghi jkl}
  do_test backcompat-1.1.5 { sql1 { PRAGMA integrity_check } } {ok}
  do_test backcompat-1.1.6 { sql2 { PRAGMA integrity_check } } {ok}

  # Test that one version can roll back a hot-journal file left in the
  # file-system by the other version.
  #
  do_test backcompat-1.2.1 { sql1 {
    PRAGMA cache_size = 10;
    BEGIN;
      INSERT INTO t1 VALUES(randomblob(400), randomblob(400));
      INSERT INTO t1 SELECT randomblob(400), randomblob(400) FROM t1;
      INSERT INTO t1 SELECT randomblob(400), randomblob(400) FROM t1;
      INSERT INTO t1 SELECT randomblob(400), randomblob(400) FROM t1;
      INSERT INTO t1 SELECT randomblob(400), randomblob(400) FROM t1;
    COMMIT;
  } } {}
  set cksum1 [sql1 {SELECT md5sum(a), md5sum(b) FROM t1}]
  set cksum2 [sql2 {SELECT md5sum(a), md5sum(b) FROM t1}]
  do_test backcompat-1.2.2 [list string compare $cksum1 $cksum2] 0

  do_test backcompat-1.2.3 { sql1 {
    BEGIN;
      UPDATE t1 SET a = randomblob(500);
  } } {}
  set data [read_file_system]
  do_test backcompat-1.2.4 { sql1 { COMMIT } } {}

  set same [expr {[sql2 {SELECT md5sum(a), md5sum(b) FROM t1}] == $cksum2}]
  do_test backcompat-1.2.5 [list set {} $same] 0

  write_file_system $data
  set same [expr {[sql2 {SELECT md5sum(a), md5sum(b) FROM t1}] == $cksum2}]
  do_test backcompat-1.2.6 [list set {} $same] 1

  do_test backcompat-1.2.7 { sql2 { PRAGMA integrity_check } } {ok}
  do_test backcompat-1.2.8 { sql2 { PRAGMA integrity_check } } {ok}
}

foreach k [lsort [array names ::incompatible]] {
  puts "ERROR: Detected incompatibility with version $k"
}

finish_test

  }
}

# Launch another testfixture process to be controlled by this one. A
# channel name is returned that may be passed as the first argument to proc
# 'testfixture' to execute a command. The child testfixture process is shut
# down by closing the channel.
proc launch_testfixture {{prg ""}} {
  write_main_loop

  if {$prg eq ""} { set prg [info nameofexec] }
  if {$prg eq ""} { set prg [file join . testfixture] }

  set chan [open "|$prg tf_main.tcl" r+]
  fconfigure $chan -buffering line
  set rc [catch { 
    testfixture $chan "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
  }]
  if {$rc} {
    testfixture $chan "set ::sqlite_pending_byte $::sqlite_pending_byte"
  }
  return $chan
}

# Execute a command in a child testfixture process, connected by two-way
# channel $chan. Return the result of the command, or an error message.
#
proc testfixture {chan cmd} {