Return to thread_common.tcl CVS log

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

Annotation of embedaddon/sqlite3/test/thread_common.tcl, revision 1.1.1.1

1.1       misho       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: