Return to thread_common.tcl CVS log

Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / sqlite3 / test

sqlite3

    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.1.1.1 2012/02/21 17:04:16 misho 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: