gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/bc_common.tcl (about) 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 }