1 /* 2 ** 2007 September 9 3 ** 4 ** The author disclaims copyright to this source code. In place of 5 ** a legal notice, here is a blessing: 6 ** 7 ** May you do good and not evil. 8 ** May you find forgiveness for yourself and forgive others. 9 ** May you share freely, never taking more than you give. 10 ** 11 ************************************************************************* 12 ** 13 ** This file contains the implementation of some Tcl commands used to 14 ** test that sqlite3 database handles may be concurrently accessed by 15 ** multiple threads. Right now this only works on unix. 16 ** 17 ** $Id: test_thread.c,v 1.10 2009/02/03 19:55:20 shane Exp $ 18 */ 19 20 #include "sqliteInt.h" 21 #include <tcl.h> 22 23 #if SQLITE_THREADSAFE 24 25 #include <errno.h> 26 27 #if !defined(_MSC_VER) 28 #include <unistd.h> 29 #endif 30 31 /* 32 ** One of these is allocated for each thread created by [sqlthread spawn]. 33 */ 34 typedef struct SqlThread SqlThread; 35 struct SqlThread { 36 Tcl_ThreadId parent; /* Thread id of parent thread */ 37 Tcl_Interp *interp; /* Parent interpreter */ 38 char *zScript; /* The script to execute. */ 39 char *zVarname; /* Varname in parent script */ 40 }; 41 42 /* 43 ** A custom Tcl_Event type used by this module. When the event is 44 ** handled, script zScript is evaluated in interpreter interp. If 45 ** the evaluation throws an exception (returns TCL_ERROR), then the 46 ** error is handled by Tcl_BackgroundError(). If no error occurs, 47 ** the result is simply discarded. 48 */ 49 typedef struct EvalEvent EvalEvent; 50 struct EvalEvent { 51 Tcl_Event base; /* Base class of type Tcl_Event */ 52 char *zScript; /* The script to execute. */ 53 Tcl_Interp *interp; /* The interpreter to execute it in. */ 54 }; 55 56 static Tcl_ObjCmdProc sqlthread_proc; 57 static Tcl_ObjCmdProc clock_seconds_proc; 58 int Sqlitetest1_Init(Tcl_Interp *); 59 60 /* 61 ** Handler for events of type EvalEvent. 62 */ 63 static int tclScriptEvent(Tcl_Event *evPtr, int flags){ 64 int rc; 65 EvalEvent *p = (EvalEvent *)evPtr; 66 rc = Tcl_Eval(p->interp, p->zScript); 67 if( rc!=TCL_OK ){ 68 Tcl_BackgroundError(p->interp); 69 } 70 UNUSED_PARAMETER(flags); 71 return 1; 72 } 73 74 /* 75 ** Register an EvalEvent to evaluate the script pScript in the 76 ** parent interpreter/thread of SqlThread p. 77 */ 78 static void postToParent(SqlThread *p, Tcl_Obj *pScript){ 79 EvalEvent *pEvent; 80 char *zMsg; 81 int nMsg; 82 83 zMsg = Tcl_GetStringFromObj(pScript, &nMsg); 84 pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1); 85 pEvent->base.nextPtr = 0; 86 pEvent->base.proc = tclScriptEvent; 87 pEvent->zScript = (char *)&pEvent[1]; 88 memcpy(pEvent->zScript, zMsg, nMsg+1); 89 pEvent->interp = p->interp; 90 91 Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL); 92 Tcl_ThreadAlert(p->parent); 93 } 94 95 /* 96 ** The main function for threads created with [sqlthread spawn]. 97 */ 98 static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){ 99 Tcl_Interp *interp; 100 Tcl_Obj *pRes; 101 Tcl_Obj *pList; 102 int rc; 103 SqlThread *p = (SqlThread *)pSqlThread; 104 extern int Sqlitetest_mutex_Init(Tcl_Interp*); 105 106 interp = Tcl_CreateInterp(); 107 Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0); 108 Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0); 109 Sqlitetest1_Init(interp); 110 Sqlitetest_mutex_Init(interp); 111 112 rc = Tcl_Eval(interp, p->zScript); 113 pRes = Tcl_GetObjResult(interp); 114 pList = Tcl_NewObj(); 115 Tcl_IncrRefCount(pList); 116 Tcl_IncrRefCount(pRes); 117 118 if( rc!=TCL_OK ){ 119 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1)); 120 Tcl_ListObjAppendElement(interp, pList, pRes); 121 postToParent(p, pList); 122 Tcl_DecrRefCount(pList); 123 pList = Tcl_NewObj(); 124 } 125 126 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1)); 127 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1)); 128 Tcl_ListObjAppendElement(interp, pList, pRes); 129 postToParent(p, pList); 130 131 ckfree((void *)p); 132 Tcl_DecrRefCount(pList); 133 Tcl_DecrRefCount(pRes); 134 Tcl_DeleteInterp(interp); 135 TCL_THREAD_CREATE_RETURN; 136 } 137 138 /* 139 ** sqlthread spawn VARNAME SCRIPT 140 ** 141 ** Spawn a new thread with its own Tcl interpreter and run the 142 ** specified SCRIPT(s) in it. The thread terminates after running 143 ** the script. The result of the script is stored in the variable 144 ** VARNAME. 145 ** 146 ** The caller can wait for the script to terminate using [vwait VARNAME]. 147 */ 148 static int sqlthread_spawn( 149 ClientData clientData, 150 Tcl_Interp *interp, 151 int objc, 152 Tcl_Obj *CONST objv[] 153 ){ 154 Tcl_ThreadId x; 155 SqlThread *pNew; 156 int rc; 157 158 int nVarname; char *zVarname; 159 int nScript; char *zScript; 160 161 /* Parameters for thread creation */ 162 const int nStack = TCL_THREAD_STACK_DEFAULT; 163 const int flags = TCL_THREAD_NOFLAGS; 164 165 assert(objc==4); 166 UNUSED_PARAMETER(clientData); 167 UNUSED_PARAMETER(objc); 168 169 zVarname = Tcl_GetStringFromObj(objv[2], &nVarname); 170 zScript = Tcl_GetStringFromObj(objv[3], &nScript); 171 172 pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2); 173 pNew->zVarname = (char *)&pNew[1]; 174 pNew->zScript = (char *)&pNew->zVarname[nVarname+1]; 175 memcpy(pNew->zVarname, zVarname, nVarname+1); 176 memcpy(pNew->zScript, zScript, nScript+1); 177 pNew->parent = Tcl_GetCurrentThread(); 178 pNew->interp = interp; 179 180 rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags); 181 if( rc!=TCL_OK ){ 182 Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0); 183 ckfree((char *)pNew); 184 return TCL_ERROR; 185 } 186 187 return TCL_OK; 188 } 189 190 /* 191 ** sqlthread parent SCRIPT 192 ** 193 ** This can be called by spawned threads only. It sends the specified 194 ** script back to the parent thread for execution. The result of 195 ** evaluating the SCRIPT is returned. The parent thread must enter 196 ** the event loop for this to work - otherwise the caller will 197 ** block indefinitely. 198 ** 199 ** NOTE: At the moment, this doesn't work. FIXME. 200 */ 201 static int sqlthread_parent( 202 ClientData clientData, 203 Tcl_Interp *interp, 204 int objc, 205 Tcl_Obj *CONST objv[] 206 ){ 207 EvalEvent *pEvent; 208 char *zMsg; 209 int nMsg; 210 SqlThread *p = (SqlThread *)clientData; 211 212 assert(objc==3); 213 UNUSED_PARAMETER(objc); 214 215 if( p==0 ){ 216 Tcl_AppendResult(interp, "no parent thread", 0); 217 return TCL_ERROR; 218 } 219 220 zMsg = Tcl_GetStringFromObj(objv[2], &nMsg); 221 pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1); 222 pEvent->base.nextPtr = 0; 223 pEvent->base.proc = tclScriptEvent; 224 pEvent->zScript = (char *)&pEvent[1]; 225 memcpy(pEvent->zScript, zMsg, nMsg+1); 226 pEvent->interp = p->interp; 227 Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL); 228 Tcl_ThreadAlert(p->parent); 229 230 return TCL_OK; 231 } 232 233 static int xBusy(void *pArg, int nBusy){ 234 UNUSED_PARAMETER(pArg); 235 UNUSED_PARAMETER(nBusy); 236 sqlite3_sleep(50); 237 return 1; /* Try again... */ 238 } 239 240 /* 241 ** sqlthread open 242 ** 243 ** Open a database handle and return the string representation of 244 ** the pointer value. 245 */ 246 static int sqlthread_open( 247 ClientData clientData, 248 Tcl_Interp *interp, 249 int objc, 250 Tcl_Obj *CONST objv[] 251 ){ 252 int sqlite3TestMakePointerStr(Tcl_Interp *interp, char *zPtr, void *p); 253 254 const char *zFilename; 255 sqlite3 *db; 256 int rc; 257 char zBuf[100]; 258 extern void Md5_Register(sqlite3*); 259 260 UNUSED_PARAMETER(clientData); 261 UNUSED_PARAMETER(objc); 262 263 zFilename = Tcl_GetString(objv[2]); 264 rc = sqlite3_open(zFilename, &db); 265 Md5_Register(db); 266 sqlite3_busy_handler(db, xBusy, 0); 267 268 if( sqlite3TestMakePointerStr(interp, zBuf, db) ) return TCL_ERROR; 269 Tcl_AppendResult(interp, zBuf, 0); 270 271 return TCL_OK; 272 } 273 274 275 /* 276 ** sqlthread open 277 ** 278 ** Return the current thread-id (Tcl_GetCurrentThread()) cast to 279 ** an integer. 280 */ 281 static int sqlthread_id( 282 ClientData clientData, 283 Tcl_Interp *interp, 284 int objc, 285 Tcl_Obj *CONST objv[] 286 ){ 287 Tcl_ThreadId id = Tcl_GetCurrentThread(); 288 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id)); 289 UNUSED_PARAMETER(clientData); 290 UNUSED_PARAMETER(objc); 291 UNUSED_PARAMETER(objv); 292 return TCL_OK; 293 } 294 295 296 /* 297 ** Dispatch routine for the sub-commands of [sqlthread]. 298 */ 299 static int sqlthread_proc( 300 ClientData clientData, 301 Tcl_Interp *interp, 302 int objc, 303 Tcl_Obj *CONST objv[] 304 ){ 305 struct SubCommand { 306 char *zName; 307 Tcl_ObjCmdProc *xProc; 308 int nArg; 309 char *zUsage; 310 } aSub[] = { 311 {"parent", sqlthread_parent, 1, "SCRIPT"}, 312 {"spawn", sqlthread_spawn, 2, "VARNAME SCRIPT"}, 313 {"open", sqlthread_open, 1, "DBNAME"}, 314 {"id", sqlthread_id, 0, ""}, 315 {0, 0, 0} 316 }; 317 struct SubCommand *pSub; 318 int rc; 319 int iIndex; 320 321 if( objc<2 ){ 322 Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND"); 323 return TCL_ERROR; 324 } 325 326 rc = Tcl_GetIndexFromObjStruct( 327 interp, objv[1], aSub, sizeof(aSub[0]), "sub-command", 0, &iIndex 328 ); 329 if( rc!=TCL_OK ) return rc; 330 pSub = &aSub[iIndex]; 331 332 if( objc!=(pSub->nArg+2) ){ 333 Tcl_WrongNumArgs(interp, 2, objv, pSub->zUsage); 334 return TCL_ERROR; 335 } 336 337 return pSub->xProc(clientData, interp, objc, objv); 338 } 339 340 /* 341 ** The [clock_seconds] command. This is more or less the same as the 342 ** regular tcl [clock seconds], except that it is available in testfixture 343 ** when linked against both Tcl 8.4 and 8.5. Because [clock seconds] is 344 ** implemented as a script in Tcl 8.5, it is not usually available to 345 ** testfixture. 346 */ 347 static int clock_seconds_proc( 348 ClientData clientData, 349 Tcl_Interp *interp, 350 int objc, 351 Tcl_Obj *CONST objv[] 352 ){ 353 Tcl_Time now; 354 Tcl_GetTime(&now); 355 Tcl_SetObjResult(interp, Tcl_NewIntObj(now.sec)); 356 UNUSED_PARAMETER(clientData); 357 UNUSED_PARAMETER(objc); 358 UNUSED_PARAMETER(objv); 359 return TCL_OK; 360 } 361 362 /* 363 ** Register commands with the TCL interpreter. 364 */ 365 int SqlitetestThread_Init(Tcl_Interp *interp){ 366 Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, 0, 0); 367 Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0); 368 return TCL_OK; 369 } 370 #else 371 int SqlitetestThread_Init(Tcl_Interp *interp){ 372 return TCL_OK; 373 } 374 #endif 375