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