1 # 2001 September 15

     2 #

     3 # Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.

     4 #

     5 # The author disclaims copyright to this source code.  In place of

     6 # a legal notice, here is a blessing:

     7 #

     8 #    May you do good and not evil.

     9 #    May you find forgiveness for yourself and forgive others.

    10 #    May you share freely, never taking more than you give.

    11 #

    12 #***********************************************************************

    13 # This file implements some common TCL routines used for regression

    14 # testing the SQLite library

    15 #

    16 # $Id: tester.tcl,v 1.134 2008/08/05 17:53:24 drh Exp $

    17 

    18 #

    19 # What for user input before continuing.  This gives an opportunity

    20 # to connect profiling tools to the process.

    21 #

    22 for {set i 0} {$i<[llength $argv]} {incr i} {

    23   if {[regexp {^-+pause$} [lindex $argv $i] all value]} {

    24     puts -nonewline "Press RETURN to begin..."

    25     flush stdout

    26     gets stdin

    27     set argv [lreplace $argv $i $i]

    28   }

    29 }

    30 

    31 set tcl_precision 15

    32 set sqlite_pending_byte 0x0010000

    33 

    34 # 

    35 # Check the command-line arguments for a default soft-heap-limit.

    36 # Store this default value in the global variable ::soft_limit and

    37 # update the soft-heap-limit each time this script is run.  In that

    38 # way if an individual test file changes the soft-heap-limit, it

    39 # will be reset at the start of the next test file.

    40 #

    41 if {![info exists soft_limit]} {

    42   set soft_limit 0

    43   for {set i 0} {$i<[llength $argv]} {incr i} {

    44     if {[regexp {^--soft-heap-limit=(.+)$} [lindex $argv $i] all value]} {

    45       if {$value!="off"} {

    46         set soft_limit $value

    47       }

    48       set argv [lreplace $argv $i $i]

    49     }

    50   }

    51 }

    52 sqlite3_soft_heap_limit $soft_limit

    53 

    54 # 

    55 # Check the command-line arguments to set the memory debugger

    56 # backtrace depth.

    57 #

    58 # See the sqlite3_memdebug_backtrace() function in mem2.c or

    59 # test_malloc.c for additional information.

    60 #

    61 for {set i 0} {$i<[llength $argv]} {incr i} {

    62   if {[lindex $argv $i] eq "--malloctrace"} {

    63     set argv [lreplace $argv $i $i]

    64     sqlite3_memdebug_backtrace 10

    65     sqlite3_memdebug_log start

    66     set tester_do_malloctrace 1

    67   }

    68 }

    69 for {set i 0} {$i<[llength $argv]} {incr i} {

    70   if {[regexp {^--backtrace=(\d+)$} [lindex $argv $i] all value]} {

    71     sqlite3_memdebug_backtrace $value

    72     set argv [lreplace $argv $i $i]

    73   }

    74 }

    75 

    76 

    77 proc ostrace_call {zCall nClick zFile i32 i64} {

    78   set s "INSERT INTO ostrace VALUES('$zCall', $nClick, '$zFile', $i32, $i64);"

    79   puts $::ostrace_fd $s

    80 }

    81 

    82 for {set i 0} {$i<[llength $argv]} {incr i} {

    83   if {[lindex $argv $i] eq "--ossummary" || [lindex $argv $i] eq "--ostrace"} {

    84     sqlite3_instvfs create -default ostrace

    85     set tester_do_ostrace 1

    86     set ostrace_fd [open ostrace.sql w]

    87     puts $ostrace_fd "BEGIN;"

    88     if {[lindex $argv $i] eq "--ostrace"} {

    89       set    s "CREATE TABLE ostrace"

    90       append s "(method TEXT, clicks INT, file TEXT, i32 INT, i64 INT);"

    91       puts $ostrace_fd $s

    92       sqlite3_instvfs configure ostrace ostrace_call

    93       sqlite3_instvfs configure ostrace ostrace_call

    94     }

    95     set argv [lreplace $argv $i $i]

    96   }

    97   if {[lindex $argv $i] eq "--binarylog"} {

    98     set tester_do_binarylog 1

    99     set argv [lreplace $argv $i $i]

   100   }

   101 }

   102 

   103 # 

   104 # Check the command-line arguments to set the maximum number of

   105 # errors tolerated before halting.

   106 #

   107 if {![info exists maxErr]} {

   108   set maxErr 1000

   109 }

   110 for {set i 0} {$i<[llength $argv]} {incr i} {

   111   if {[regexp {^--maxerror=(\d+)$} [lindex $argv $i] all maxErr]} {

   112     set argv [lreplace $argv $i $i]

   113   }

   114 }

   115 #puts "Max error = $maxErr"

   116 

   117 

   118 # Use the pager codec if it is available

   119 #

   120 if {[sqlite3 -has-codec] && [info command sqlite_orig]==""} {

   121   rename sqlite3 sqlite_orig

   122   proc sqlite3 {args} {

   123     if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} {

   124       lappend args -key {xyzzy}

   125     }

   126     uplevel 1 sqlite_orig $args

   127   }

   128 }

   129 

   130 

   131 # Create a test database

   132 #

   133 if {![info exists nTest]} {

   134   sqlite3_shutdown 

   135   install_malloc_faultsim 1 

   136   sqlite3_initialize

   137   if {[info exists tester_do_binarylog]} {

   138     sqlite3_instvfs binarylog -default binarylog ostrace.bin

   139     sqlite3_instvfs marker binarylog "$argv0 $argv"

   140   }

   141 }

   142 catch {db close}

   143 file delete -force test.db

   144 file delete -force test.db-journal

   145 sqlite3 db ./test.db

   146 set ::DB [sqlite3_connection_pointer db]

   147 if {[info exists ::SETUP_SQL]} {

   148   db eval $::SETUP_SQL

   149 }

   150 

   151 # Abort early if this script has been run before.

   152 #

   153 if {[info exists nTest]} return

   154 

   155 # Symbian OS globals

   156 set case_failure 0

   157 set nCases 0

   158 set nFailedCases 0

   159 

   160 # Set the test counters to zero

   161 #

   162 set nErr 0

   163 set nTest 0

   164 set skip_test 0

   165 set failList {}

   166 set omitList {}

   167 if {![info exists speedTest]} {

   168   set speedTest 0

   169 }

   170 

   171 # Record the fact that a sequence of tests were omitted.

   172 #

   173 proc omit_test {name reason} {

   174   global omitList

   175   lappend omitList [list $name $reason]

   176 }

   177 

   178 # Symbian OS: Added procedures to output test result in TEF format

   179 puts "<pre>"

   180 

   181 # Symbian OS: global procedure to handle test errors counter

   182 proc do_fail {name} {

   183   global case_failure nErr failList

   184   set case_failure 1

   185   incr nErr

   186   lappend ::failList $name

   187 }

   188 

   189 # Symbian OS: global procedure to output START_TESTCASE in TEF format

   190 proc start_case {name} {

   191   global case_failure nCases

   192   set case_failure 0

   193   incr nCases

   194   puts "<font color=00AF00> START_TESTCASE $name <\/font>"

   195 }

   196 

   197 # Symbian OS: global procedure to output END_TESTCASE in TEF format

   198 proc end_case {name} {

   199   global case_failure nFailedCases

   200   if {$case_failure} {

   201     incr nFailedCases

   202     puts "<font color=FF0000> END_TESTCASE $name ***TestCaseResult = FAIL <\/font>"

   203   } else {

   204     puts "<font color=00AF00> END_TESTCASE $name ***TestCaseResult = PASS <\/font>"

   205   }

   206 }

   207 

   208 # Symbian OS: global procedure to output test summary in TEF format

   209 proc tef_summary {} {

   210   global nCases nFailedCases

   211   set nPass [expr "$nCases - $nFailedCases"]

   212   puts "<font color=00AFFF>TEST STEP SUMMARY:<\/font>"

   213   puts "<font color=00AF00>PASS = $nCases<\/font>"

   214   puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"

   215   puts "<font color=00AFFF>TEST CASE SUMMARY:<\/font>"

   216   puts "<font color=00AF00>PASS = $nCases<\/font>"

   217   puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"

   218   puts "<\/pre>"

   219   flush stdout

   220 }

   221 

   222 # Invoke the do_test procedure to run a single test 

   223 #

   224 proc do_test {name cmd expected} {

   225   global argv nErr nTest skip_test maxErr

   226   sqlite3_memdebug_settitle $name

   227   if {[info exists ::tester_do_binarylog]} {

   228     sqlite3_instvfs marker binarylog "Start of $name"

   229   }

   230   if {$skip_test} {

   231     set skip_test 0

   232     return

   233   }

   234   if {[llength $argv]==0} { 

   235     set go 1

   236   } else {

   237     set go 0

   238     foreach pattern $argv {

   239       if {[string match $pattern $name]} {

   240         set go 1

   241         break

   242       }

   243     }

   244   }

   245   if {!$go} return

   246   incr nTest

   247   puts -nonewline $name...

   248   flush stdout

   249   if {[catch {uplevel #0 "$cmd;\n"} result]} {

   250     puts "\nError: $result"

   251     # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)

   252     do_fail $name 

   253     if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing}

   254   } elseif {[string compare $result $expected]} {

   255     puts "\nExpected: \[$expected\]\n     Got: \[$result\]"

   256     # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)

   257     do_fail $name 

   258     if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing}

   259   } else {

   260     puts " Ok"

   261   }

   262   flush stdout

   263   if {[info exists ::tester_do_binarylog]} {

   264     sqlite3_instvfs marker binarylog "End of $name"

   265   }

   266 }

   267 

   268 # Run an SQL script.  

   269 # Return the number of microseconds per statement.

   270 #

   271 proc speed_trial {name numstmt units sql} {

   272   puts -nonewline [format {%-21.21s } $name...]

   273   flush stdout

   274   set speed [time {sqlite3_exec_nr db $sql}]

   275   set tm [lindex $speed 0]

   276   if {$tm == 0} {

   277     set rate [format %20s "many"]

   278   } else {

   279     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]

   280   }

   281   set u2 $units/s

   282   puts [format {%12d uS %s %s} $tm $rate $u2]

   283   global total_time

   284   set total_time [expr {$total_time+$tm}]

   285 }

   286 proc speed_trial_tcl {name numstmt units script} {

   287   puts -nonewline [format {%-21.21s } $name...]

   288   flush stdout

   289   set speed [time {eval $script}]

   290   set tm [lindex $speed 0]

   291   if {$tm == 0} {

   292     set rate [format %20s "many"]

   293   } else {

   294     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]

   295   }

   296   set u2 $units/s

   297   puts [format {%12d uS %s %s} $tm $rate $u2]

   298   global total_time

   299   set total_time [expr {$total_time+$tm}]

   300 }

   301 proc speed_trial_init {name} {

   302   global total_time

   303   set total_time 0

   304 }

   305 proc speed_trial_summary {name} {

   306   global total_time

   307   puts [format {%-21.21s %12d uS TOTAL} $name $total_time]

   308 }

   309 

   310 # Run this routine last

   311 #

   312 proc finish_test {} {

   313   finalize_testing

   314 }

   315 proc finalize_testing {} {

   316   global nTest nErr sqlite_open_file_count omitList

   317 

   318   catch {db close}

   319   catch {db2 close}

   320   catch {db3 close}

   321 

   322   vfs_unlink_test

   323   sqlite3 db {}

   324   # sqlite3_clear_tsd_memdebug

   325   db close

   326   sqlite3_reset_auto_extension

   327 

   328   set heaplimit [sqlite3_soft_heap_limit]

   329   if {$heaplimit!=$::soft_limit} {

   330     puts "soft-heap-limit changed by this script\

   331           from $::soft_limit to $heaplimit"

   332   } elseif {$heaplimit!="" && $heaplimit>0} {

   333     puts "soft-heap-limit set to $heaplimit"

   334   }

   335   

   336   sqlite3_soft_heap_limit 0

   337   incr nTest

   338   puts "$nErr errors out of $nTest tests"

   339   if {$nErr>0} {

   340     puts "Failures on these tests: $::failList"

   341   }

   342   

   343   if {[llength $omitList]>0} {

   344     puts "Omitted test cases:"

   345     set prec {}

   346     foreach {rec} [lsort $omitList] {

   347       if {$rec==$prec} continue

   348       set prec $rec

   349       puts [format {  %-12s %s} [lindex $rec 0] [lindex $rec 1]]

   350     }

   351   }

   352   

   353   if {$nErr>0 && ![working_64bit_int]} {

   354     puts "******************************************************************"

   355     puts "N.B.:  The version of TCL that you used to build this test harness"

   356     puts "is defective in that it does not support 64-bit integers.  Some or"

   357     puts "all of the test failures above might be a result from this defect"

   358     puts "in your TCL build."

   359     puts "******************************************************************"

   360   }

   361   if {[info exists ::tester_do_binarylog]} {

   362     sqlite3_instvfs destroy binarylog

   363   }

   364 

   365   if {$sqlite_open_file_count} {

   366     puts "$sqlite_open_file_count files were left open"

   367     incr nErr

   368   }

   369   

   370   if {[info exists ::tester_do_ostrace]} {

   371     puts "Writing ostrace.sql..."

   372     set fd $::ostrace_fd

   373 

   374     puts -nonewline $fd "CREATE TABLE ossummary"

   375     puts $fd "(method TEXT, clicks INTEGER, count INTEGER);"

   376     foreach row [sqlite3_instvfs report ostrace] {

   377       foreach {method count clicks} $row break

   378       puts $fd "INSERT INTO ossummary VALUES('$method', $clicks, $count);"

   379     }

   380     puts $fd "COMMIT;"

   381     close $fd

   382     sqlite3_instvfs destroy ostrace

   383   }

   384   

   385   if {[sqlite3_memory_used]>0} {

   386     puts "Unfreed memory: [sqlite3_memory_used] bytes"

   387     incr nErr

   388     ifcapable memdebug||mem5||(mem3&&debug) {

   389       puts "Writing unfreed memory log to \"./memleak.txt\""

   390       sqlite3_memdebug_dump ./memleak.txt

   391     }

   392   } else {

   393     puts "All memory allocations freed - no leaks"

   394     ifcapable memdebug||mem5 {

   395       sqlite3_memdebug_dump ./memusage.txt

   396     }

   397   }

   398   

   399   show_memstats

   400   puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"

   401   puts "Current memory usage: [sqlite3_memory_highwater] bytes"

   402   if {[info commands sqlite3_memdebug_malloc_count] ne ""} {

   403     puts "Number of malloc()  : [sqlite3_memdebug_malloc_count] calls"

   404   }

   405 

   406   if {[info exists ::tester_do_malloctrace]} {

   407     puts "Writing mallocs.sql..."

   408     memdebug_log_sql

   409     sqlite3_memdebug_log stop

   410     sqlite3_memdebug_log clear

   411 

   412     if {[sqlite3_memory_used]>0} {

   413       puts "Writing leaks.sql..."

   414       sqlite3_memdebug_log sync

   415       memdebug_log_sql leaks.sql

   416     }

   417   }

   418 

   419   foreach f [glob -nocomplain test.db-*-journal] {

   420     file delete -force $f

   421   }

   422   

   423   foreach f [glob -nocomplain test.db-mj*] {

   424     file delete -force $f

   425   }

   426 

   427 #Symbian OS - delete_test_files() is called to cleanup after the tests execution

   428   delete_test_files

   429 

   430 # Symbian OS: output TEF format summary

   431   tef_summary

   432 

   433   exit [expr {$nErr>0}]

   434 }

   435 

   436 # Display memory statistics for analysis and debugging purposes.

   437 #

   438 proc show_memstats {} {

   439   set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]

   440   set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]

   441   set val [format {now %10d  max %10d  max-size %10d} \

   442               [lindex $x 1] [lindex $x 2] [lindex $y 2]]

   443   puts "Memory used:          $val"

   444   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]

   445   set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]

   446   set val [format {now %10d  max %10d  max-size %10d} \

   447               [lindex $x 1] [lindex $x 2] [lindex $y 2]]

   448   puts "Page-cache used:      $val"

   449   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]

   450   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]

   451   puts "Page-cache overflow:  $val"

   452   set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]

   453   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]

   454   puts "Scratch memory used:  $val"

   455   set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]

   456   set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]

   457   set val [format {now %10d  max %10d  max-size %10d} \

   458                [lindex $x 1] [lindex $x 2] [lindex $y 2]]

   459   puts "Scratch overflow:     $val"

   460   ifcapable yytrackmaxstackdepth {

   461     set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]

   462     set val [format {               max %10d} [lindex $x 2]]

   463     puts "Parser stack depth:    $val"

   464   }

   465 }

   466 

   467 # A procedure to execute SQL

   468 #

   469 proc execsql {sql {db db}} {

   470   # puts "SQL = $sql"

   471   uplevel [list $db eval $sql]

   472 }

   473 

   474 # Execute SQL and catch exceptions.

   475 #

   476 proc catchsql {sql {db db}} {

   477   # puts "SQL = $sql"

   478   set r [catch {$db eval $sql} msg]

   479   lappend r $msg

   480   return $r

   481 }

   482 

   483 # Do an VDBE code dump on the SQL given

   484 #

   485 proc explain {sql {db db}} {

   486   puts ""

   487   puts "addr  opcode        p1      p2      p3      p4               p5  #"

   488   puts "----  ------------  ------  ------  ------  ---------------  --  -"

   489   $db eval "explain $sql" {} {

   490     puts [format {%-4d  %-12.12s  %-6d  %-6d  %-6d  % -17s %s  %s} \

   491       $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment

   492     ]

   493   }

   494 }

   495 

   496 # Show the VDBE program for an SQL statement but omit the Trace

   497 # opcode at the beginning.  This procedure can be used to prove

   498 # that different SQL statements generate exactly the same VDBE code.

   499 #

   500 proc explain_no_trace {sql} {

   501   set tr [db eval "EXPLAIN $sql"]

   502   return [lrange $tr 7 end]

   503 }

   504 

   505 # Another procedure to execute SQL.  This one includes the field

   506 # names in the returned list.

   507 #

   508 proc execsql2 {sql} {

   509   set result {}

   510   db eval $sql data {

   511     foreach f $data(*) {

   512       lappend result $f $data($f)

   513     }

   514   }

   515   return $result

   516 }

   517 

   518 # Use the non-callback API to execute multiple SQL statements

   519 #

   520 proc stepsql {dbptr sql} {

   521   set sql [string trim $sql]

   522   set r 0

   523   while {[string length $sql]>0} {

   524     if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {

   525       return [list 1 $vm]

   526     }

   527     set sql [string trim $sqltail]

   528 #    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {

   529 #      foreach v $VAL {lappend r $v}

   530 #    }

   531     while {[sqlite3_step $vm]=="SQLITE_ROW"} {

   532       for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {

   533         lappend r [sqlite3_column_text $vm $i]

   534       }

   535     }

   536     if {[catch {sqlite3_finalize $vm} errmsg]} {

   537       return [list 1 $errmsg]

   538     }

   539   }

   540   return $r

   541 }

   542 

   543 # Delete a file or directory

   544 #

   545 proc forcedelete {filename} {

   546   if {[catch {file delete -force $filename}]} {

   547     exec rm -rf $filename

   548   }

   549 }

   550 

   551 # Do an integrity check of the entire database

   552 #

   553 proc integrity_check {name} {

   554   ifcapable integrityck {

   555     do_test $name {

   556       execsql {PRAGMA integrity_check}

   557     } {ok}

   558   }

   559 }

   560 

   561 proc fix_ifcapable_expr {expr} {

   562   set ret ""

   563   set state 0

   564   for {set i 0} {$i < [string length $expr]} {incr i} {

   565     set char [string range $expr $i $i]

   566     set newstate [expr {[string is alnum $char] || $char eq "_"}]

   567     if {$newstate && !$state} {

   568       append ret {$::sqlite_options(}

   569     }

   570     if {!$newstate && $state} {

   571       append ret )

   572     }

   573     append ret $char

   574     set state $newstate

   575   }

   576   if {$state} {append ret )}

   577   return $ret

   578 }

   579 

   580 # Evaluate a boolean expression of capabilities.  If true, execute the

   581 # code.  Omit the code if false.

   582 #

   583 proc ifcapable {expr code {else ""} {elsecode ""}} {

   584   #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2

   585   set e2 [fix_ifcapable_expr $expr]

   586   if ($e2) {

   587     set c [catch {uplevel 1 $code} r]

   588   } else {

   589     set c [catch {uplevel 1 $elsecode} r]

   590   }

   591   return -code $c $r

   592 }

   593 

   594 # This proc execs a seperate process that crashes midway through executing

   595 # the SQL script $sql on database test.db.

   596 #

   597 # The crash occurs during a sync() of file $crashfile. When the crash

   598 # occurs a random subset of all unsynced writes made by the process are

   599 # written into the files on disk. Argument $crashdelay indicates the

   600 # number of file syncs to wait before crashing.

   601 #

   602 # The return value is a list of two elements. The first element is a

   603 # boolean, indicating whether or not the process actually crashed or

   604 # reported some other error. The second element in the returned list is the

   605 # error message. This is "child process exited abnormally" if the crash

   606 # occured.

   607 #

   608 #   crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql

   609 #

   610 proc crashsql {args} {

   611   if {$::tcl_platform(platform)!="unix"} {

   612     error "crashsql should only be used on unix"

   613   }

   614 

   615   set blocksize ""

   616   set crashdelay 1

   617   set prngseed 0

   618   set tclbody {}

   619   set crashfile ""

   620   set dc ""

   621   set sql [lindex $args end]

   622   

   623   for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {

   624     set z [lindex $args $ii]

   625     set n [string length $z]

   626     set z2 [lindex $args [expr $ii+1]]

   627 

   628     if     {$n>1 && [string first $z -delay]==0}     {set crashdelay $z2} \

   629     elseif {$n>1 && [string first $z -seed]==0}      {set prngseed $z2} \

   630     elseif {$n>1 && [string first $z -file]==0}      {set crashfile $z2}  \

   631     elseif {$n>1 && [string first $z -tclbody]==0}   {set tclbody $z2}  \

   632     elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \

   633     elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \

   634     else   { error "Unrecognized option: $z" }

   635   }

   636 

   637   if {$crashfile eq ""} {

   638     error "Compulsory option -file missing"

   639   }

   640 

   641   set cfile [file join [pwd] $crashfile]

   642 

   643   set f [open crash.tcl w]

   644   puts $f "sqlite3_crash_enable 1"

   645   puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"

   646   puts $f "set sqlite_pending_byte $::sqlite_pending_byte"

   647   puts $f "sqlite3 db test.db -vfs crash"

   648 

   649   # This block sets the cache size of the main database to 10

   650   # pages. This is done in case the build is configured to omit

   651   # "PRAGMA cache_size".

   652   puts $f {db eval {SELECT * FROM sqlite_master;}}

   653   puts $f {set bt [btree_from_db db]}

   654   puts $f {btree_set_cache_size $bt 10}

   655   if {$prngseed} {

   656     set seed [expr {$prngseed%10007+1}]

   657     # puts seed=$seed

   658     puts $f "db eval {SELECT randomblob($seed)}"

   659   }

   660 

   661   if {[string length $tclbody]>0} {

   662     puts $f $tclbody

   663   }

   664   if {[string length $sql]>0} {

   665     puts $f "db eval {"

   666     puts $f   "$sql"

   667     puts $f "}"

   668   }

   669   close $f

   670 

   671   set r [catch {

   672     exec [info nameofexec] crash.tcl >@stdout

   673   } msg]

   674   lappend r $msg

   675 }

   676 

   677 # Usage: do_ioerr_test <test number> <options...>

   678 #

   679 # This proc is used to implement test cases that check that IO errors

   680 # are correctly handled. The first argument, <test number>, is an integer 

   681 # used to name the tests executed by this proc. Options are as follows:

   682 #

   683 #     -tclprep          TCL script to run to prepare test.

   684 #     -sqlprep          SQL script to run to prepare test.

   685 #     -tclbody          TCL script to run with IO error simulation.

   686 #     -sqlbody          TCL script to run with IO error simulation.

   687 #     -exclude          List of 'N' values not to test.

   688 #     -erc              Use extended result codes

   689 #     -persist          Make simulated I/O errors persistent

   690 #     -start            Value of 'N' to begin with (default 1)

   691 #

   692 #     -cksum            Boolean. If true, test that the database does

   693 #                       not change during the execution of the test case.

   694 #

   695 proc do_ioerr_test {testname args} {

   696 

   697   set ::ioerropts(-start) 1

   698   set ::ioerropts(-cksum) 0

   699   set ::ioerropts(-erc) 0

   700   set ::ioerropts(-count) 100000000

   701   set ::ioerropts(-persist) 1

   702   set ::ioerropts(-ckrefcount) 0

   703   set ::ioerropts(-restoreprng) 1

   704   array set ::ioerropts $args

   705 

   706   # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are

   707   # a couple of obscure IO errors that do not return them.

   708   set ::ioerropts(-erc) 0

   709 

   710   set ::go 1

   711   #reset_prng_state

   712   save_prng_state

   713   for {set n $::ioerropts(-start)} {$::go && $n<200} {incr n} {

   714     set ::TN $n

   715     incr ::ioerropts(-count) -1

   716     if {$::ioerropts(-count)<0} break

   717  

   718     # Skip this IO error if it was specified with the "-exclude" option.

   719     if {[info exists ::ioerropts(-exclude)]} {

   720       if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue

   721     }

   722     if {$::ioerropts(-restoreprng)} {

   723       restore_prng_state

   724     }

   725 

   726     # Delete the files test.db and test2.db, then execute the TCL and 

   727     # SQL (in that order) to prepare for the test case.

   728     do_test $testname.$n.1 {

   729       set ::sqlite_io_error_pending 0

   730       catch {db close}

   731       catch {file delete -force test.db}

   732       catch {file delete -force test.db-journal}

   733       catch {file delete -force test2.db}

   734       catch {file delete -force test2.db-journal}

   735       set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]

   736       sqlite3_extended_result_codes $::DB $::ioerropts(-erc)

   737       if {[info exists ::ioerropts(-tclprep)]} {

   738         eval $::ioerropts(-tclprep)

   739       }

   740       if {[info exists ::ioerropts(-sqlprep)]} {

   741         execsql $::ioerropts(-sqlprep)

   742       }

   743       expr 0

   744     } {0}

   745 

   746     # Read the 'checksum' of the database.

   747     if {$::ioerropts(-cksum)} {

   748       set checksum [cksum]

   749     }

   750 

   751     # Set the Nth IO error to fail.

   752     do_test $testname.$n.2 [subst {

   753       set ::sqlite_io_error_persist $::ioerropts(-persist)

   754       set ::sqlite_io_error_pending $n

   755     }] $n

   756   

   757     # Create a single TCL script from the TCL and SQL specified

   758     # as the body of the test.

   759     set ::ioerrorbody {}

   760     if {[info exists ::ioerropts(-tclbody)]} {

   761       append ::ioerrorbody "$::ioerropts(-tclbody)\n"

   762     }

   763     if {[info exists ::ioerropts(-sqlbody)]} {

   764       append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"

   765     }

   766 

   767     # Execute the TCL Script created in the above block. If

   768     # there are at least N IO operations performed by SQLite as

   769     # a result of the script, the Nth will fail.

   770     do_test $testname.$n.3 {

   771       set ::sqlite_io_error_hit 0

   772       set ::sqlite_io_error_hardhit 0

   773       set r [catch $::ioerrorbody msg]

   774       set ::errseen $r

   775       set rc [sqlite3_errcode $::DB]

   776       if {$::ioerropts(-erc)} {

   777         # If we are in extended result code mode, make sure all of the

   778         # IOERRs we get back really do have their extended code values.

   779         # If an extended result code is returned, the sqlite3_errcode

   780         # TCLcommand will return a string of the form:  SQLITE_IOERR+nnnn

   781         # where nnnn is a number

   782         if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {

   783           return $rc

   784         }

   785       } else {

   786         # If we are not in extended result code mode, make sure no

   787         # extended error codes are returned.

   788         if {[regexp {\+\d} $rc]} {

   789           return $rc

   790         }

   791       }

   792       # The test repeats as long as $::go is non-zero.  $::go starts out

   793       # as 1.  When a test runs to completion without hitting an I/O

   794       # error, that means there is no point in continuing with this test

   795       # case so set $::go to zero.

   796       #

   797       if {$::sqlite_io_error_pending>0} {

   798         set ::go 0

   799         set q 0

   800         set ::sqlite_io_error_pending 0

   801       } else {

   802         set q 1

   803       }

   804 

   805       set s [expr $::sqlite_io_error_hit==0]

   806       if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {

   807         set r 1

   808       }

   809       set ::sqlite_io_error_hit 0

   810 

   811       # One of two things must have happened. either

   812       #   1.  We never hit the IO error and the SQL returned OK

   813       #   2.  An IO error was hit and the SQL failed

   814       #

   815       expr { ($s && !$r && !$q) || (!$s && $r && $q) }

   816     } {1}

   817 

   818     set ::sqlite_io_error_hit 0

   819     set ::sqlite_io_error_pending 0

   820 

   821     # Check that no page references were leaked. There should be 

   822     # a single reference if there is still an active transaction, 

   823     # or zero otherwise.

   824     #

   825     # UPDATE: If the IO error occurs after a 'BEGIN' but before any

   826     # locks are established on database files (i.e. if the error 

   827     # occurs while attempting to detect a hot-journal file), then

   828     # there may 0 page references and an active transaction according

   829     # to [sqlite3_get_autocommit].

   830     #

   831     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {

   832       do_test $testname.$n.4 {

   833         set bt [btree_from_db db]

   834         db_enter db

   835         array set stats [btree_pager_stats $bt]

   836         db_leave db

   837         set nRef $stats(ref)

   838         expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}

   839       } {1}

   840     }

   841 

   842     # If there is an open database handle and no open transaction, 

   843     # and the pager is not running in exclusive-locking mode,

   844     # check that the pager is in "unlocked" state. Theoretically,

   845     # if a call to xUnlock() failed due to an IO error the underlying

   846     # file may still be locked.

   847     #

   848     ifcapable pragma {

   849       if { [info commands db] ne ""

   850         && $::ioerropts(-ckrefcount)

   851         && [db one {pragma locking_mode}] eq "normal"

   852         && [sqlite3_get_autocommit db]

   853       } {

   854         do_test $testname.$n.5 {

   855           set bt [btree_from_db db]

   856           db_enter db

   857           array set stats [btree_pager_stats $bt]

   858           db_leave db

   859           set stats(state)

   860         } 0

   861       }

   862     }

   863 

   864     # If an IO error occured, then the checksum of the database should

   865     # be the same as before the script that caused the IO error was run.

   866     #

   867     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {

   868       do_test $testname.$n.6 {

   869         catch {db close}

   870         catch {db2 close}

   871         set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]

   872         cksum

   873       } $checksum

   874     }

   875 

   876     set ::sqlite_io_error_hardhit 0

   877     set ::sqlite_io_error_pending 0

   878     if {[info exists ::ioerropts(-cleanup)]} {

   879       catch $::ioerropts(-cleanup)

   880     }

   881   }

   882   set ::sqlite_io_error_pending 0

   883   set ::sqlite_io_error_persist 0

   884   unset ::ioerropts

   885 }

   886 

   887 # Return a checksum based on the contents of the main database associated

   888 # with connection $db

   889 #

   890 proc cksum {{db db}} {

   891   set txt [$db eval {

   892       SELECT name, type, sql FROM sqlite_master order by name

   893   }]\n

   894   foreach tbl [$db eval {

   895       SELECT name FROM sqlite_master WHERE type='table' order by name

   896   }] {

   897     append txt [$db eval "SELECT * FROM $tbl"]\n

   898   }

   899   foreach prag {default_synchronous default_cache_size} {

   900     append txt $prag-[$db eval "PRAGMA $prag"]\n

   901   }

   902   set cksum [string length $txt]-[md5 $txt]

   903   # puts $cksum-[file size test.db]

   904   return $cksum

   905 }

   906 

   907 # Generate a checksum based on the contents of the main and temp tables

   908 # database $db. If the checksum of two databases is the same, and the

   909 # integrity-check passes for both, the two databases are identical.

   910 #

   911 proc allcksum {{db db}} {

   912   set ret [list]

   913   ifcapable tempdb {

   914     set sql {

   915       SELECT name FROM sqlite_master WHERE type = 'table' UNION

   916       SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION

   917       SELECT 'sqlite_master' UNION

   918       SELECT 'sqlite_temp_master' ORDER BY 1

   919     }

   920   } else {

   921     set sql {

   922       SELECT name FROM sqlite_master WHERE type = 'table' UNION

   923       SELECT 'sqlite_master' ORDER BY 1

   924     }

   925   }

   926   set tbllist [$db eval $sql]

   927   set txt {}

   928   foreach tbl $tbllist {

   929     append txt [$db eval "SELECT * FROM $tbl"]

   930   }

   931   foreach prag {default_cache_size} {

   932     append txt $prag-[$db eval "PRAGMA $prag"]\n

   933   }

   934   # puts txt=$txt

   935   return [md5 $txt]

   936 }

   937 

   938 proc memdebug_log_sql {{filename mallocs.sql}} {

   939 

   940   set data [sqlite3_memdebug_log dump]

   941   set nFrame [expr [llength [lindex $data 0]]-2]

   942   if {$nFrame < 0} { return "" }

   943 

   944   set database temp

   945 

   946   set tbl "CREATE TABLE ${database}.malloc(nCall, nByte"

   947   for {set ii 1} {$ii <= $nFrame} {incr ii} {

   948     append tbl ", f${ii}"

   949   }

   950   append tbl ");\n"

   951 

   952   set sql ""

   953   foreach e $data {

   954     append sql "INSERT INTO ${database}.malloc VALUES([join $e ,]);\n"

   955     foreach f [lrange $e 2 end] {

   956       set frames($f) 1

   957     }

   958   }

   959 

   960   set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"

   961   set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"

   962 

   963   foreach f [array names frames] {

   964     set addr [format %x $f]

   965     set cmd "addr2line -e [info nameofexec] $addr"

   966     set line [eval exec $cmd]

   967     append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"

   968 

   969     set file [lindex [split $line :] 0]

   970     set files($file) 1

   971   }

   972 

   973   foreach f [array names files] {

   974     set contents ""

   975     catch {

   976       set fd [open $f]

   977       set contents [read $fd]

   978       close $fd

   979     }

   980     set contents [string map {' ''} $contents]

   981     append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"

   982   }

   983 

   984   set fd [open $filename w]

   985   puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"

   986   close $fd

   987 }

   988 

   989 # Copy file $from into $to. This is used because some versions of

   990 # TCL for windows (notably the 8.4.1 binary package shipped with the

   991 # current mingw release) have a broken "file copy" command.

   992 #

   993 proc copy_file {from to} {

   994   if {$::tcl_platform(platform)=="unix"} {

   995     file copy -force $from $to

   996   } else {

   997     set f [open $from]

   998     fconfigure $f -translation binary

   999     set t [open $to w]

  1000     fconfigure $t -translation binary

  1001     puts -nonewline $t [read $f [file size $from]]

  1002     close $t

  1003     close $f

  1004   }

  1005 }

  1006 

  1007 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set

  1008 # to non-zero, then set the global variable $AUTOVACUUM to 1.

  1009 set AUTOVACUUM $sqlite_options(default_autovacuum)