Home | History | Annotate | Download | only in test 
      1 # 2007 September 10
      2 #
      3 # The author disclaims copyright to this source code.  In place of
      4 # a legal notice, here is a blessing:
      5 #
      6 #    May you do good and not evil.
      7 #    May you find forgiveness for yourself and forgive others.
      8 #    May you share freely, never taking more than you give.
      9 #
     10 #***********************************************************************
     11 #
     12 # $Id: thread_common.tcl,v 1.5 2009/03/26 14:48:07 danielk1977 Exp $
     13 
     14 if {[info exists ::thread_procs]} {
     15   return 0
     16 }
     17 
     18 # The following script is sourced by every thread spawned using
     19 # [sqlthread spawn]:
     20 set thread_procs {
     21 
     22   # Execute the supplied SQL using database handle $::DB.
     23   #
     24   proc execsql {sql} {
     25 
     26     set rc SQLITE_LOCKED
     27     while {$rc eq "SQLITE_LOCKED"
     28         || $rc eq "SQLITE_BUSY"
     29         || $rc eq "SQLITE_SCHEMA"} {
     30       set res [list]
     31 
     32       enter_db_mutex $::DB
     33       set err [catch {
     34         set ::STMT [sqlite3_prepare_v2 $::DB $sql -1 dummy_tail]
     35       } msg]
     36 
     37       if {$err == 0} {
     38         while {[set rc [sqlite3_step $::STMT]] eq "SQLITE_ROW"} {
     39           for {set i 0} {$i < [sqlite3_column_count $::STMT]} {incr i} {
     40             lappend res [sqlite3_column_text $::STMT 0]
     41           }
     42         }
     43         set rc [sqlite3_finalize $::STMT]
     44       } else {
     45         if {[lindex $msg 0]=="(6)"} {
     46           set rc SQLITE_LOCKED
     47         } else {
     48           set rc SQLITE_ERROR
     49         }
     50       }
     51 
     52       if {[string first locked [sqlite3_errmsg $::DB]]>=0} {
     53         set rc SQLITE_LOCKED
     54       }
     55       if {$rc ne "SQLITE_OK"} {
     56         set errtxt "$rc - [sqlite3_errmsg $::DB] (debug1)"
     57       }
     58       leave_db_mutex $::DB
     59 
     60       if {$rc eq "SQLITE_LOCKED" || $rc eq "SQLITE_BUSY"} {
     61         #sqlthread parent "puts \"thread [sqlthread id] is busy.  rc=$rc\""
     62         after 200
     63       } else {
     64         #sqlthread parent "puts \"thread [sqlthread id] ran $sql\""
     65       }
     66     }
     67 
     68     if {$rc ne "SQLITE_OK"} {
     69       error $errtxt
     70     }
     71     set res
     72   }
     73 
     74   proc do_test {name script result} {
     75     set res [eval $script]
     76     if {$res ne $result} {
     77       error "$name failed: expected \"$result\" got \"$res\""
     78     }
     79   }
     80 }
     81 
     82 proc thread_spawn {varname args} {
     83   sqlthread spawn $varname [join $args {;}]
     84 }
     85 
     86 # Return true if this build can run the multi-threaded tests.
     87 #
     88 proc run_thread_tests {{print_warning 0}} {
     89   ifcapable !mutex {
     90     set zProblem "SQLite build is not threadsafe"
     91   }
     92   ifcapable mutex_noop {
     93     set zProblem "SQLite build uses SQLITE_MUTEX_NOOP"
     94   }
     95   if {[info commands sqlthread] eq ""} {
     96     set zProblem "SQLite build is not threadsafe"
     97   }
     98   if {![info exists ::tcl_platform(threaded)]} {
     99     set zProblem "Linked against a non-threadsafe Tcl build"
    100   }
    101   if {[info exists zProblem]} {
    102     puts "WARNING: Multi-threaded tests skipped: $zProblem"
    103     return 0
    104   }
    105   set ::run_thread_tests_called 1
    106   return 1;
    107 }
    108 
    109 return 0
    110 
    111