test/thread_common.tcl

   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