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.8 2008/08/28 13:55:10 danielk1977 Exp $ 18 */ 19 20 #include "sqliteInt.h" 21 #include <tcl.h> 22 23 #if SQLITE_THREADSAFE && defined(TCL_THREADS) 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 100 SqlThread *p = (SqlThread *)pSqlThread; 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 107 rc = Tcl_Eval(interp, p->zScript); 108 pRes = Tcl_GetObjResult(interp); 109 pList = Tcl_NewObj(); 110 Tcl_IncrRefCount(pList); 111 Tcl_IncrRefCount(pRes); 112 113 if( rc!=TCL_OK ){ 114 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1)); 115 Tcl_ListObjAppendElement(interp, pList, pRes); 116 postToParent(p, pList); 117 Tcl_DecrRefCount(pList); 118 pList = Tcl_NewObj(); 119 } 120 121 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1)); 122 Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1)); 123 Tcl_ListObjAppendElement(interp, pList, pRes); 124 postToParent(p, pList); 125 126 ckfree((void *)p); 127 Tcl_DecrRefCount(pList); 128 Tcl_DecrRefCount(pRes); 129 Tcl_DeleteInterp(interp); 130 return; 131 } 132 133 /* 134 ** sqlthread spawn VARNAME SCRIPT 135 ** 136 ** Spawn a new thread with its own Tcl interpreter and run the 137 ** specified SCRIPT(s) in it. The thread terminates after running 138 ** the script. The result of the script is stored in the variable 139 ** VARNAME. 140 ** 141 ** The caller can wait for the script to terminate using [vwait VARNAME]. 142 */ 143 static int sqlthread_spawn( 144 ClientData clientData, 145 Tcl_Interp *interp, 146 int objc, 147 Tcl_Obj *CONST objv[] 148 ){ 149 Tcl_ThreadId x; 150 SqlThread *pNew; 151 int rc; 152 153 int nVarname; char *zVarname; 154 int nScript; char *zScript; 155 156 /* Parameters for thread creation */ 157 const int nStack = TCL_THREAD_STACK_DEFAULT; 158 const int flags = TCL_THREAD_NOFLAGS; 159 160 assert(objc==4); 161 162 zVarname = Tcl_GetStringFromObj(objv[2], &nVarname); 163 zScript = Tcl_GetStringFromObj(objv[3], &nScript); 164 165 pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2); 166 pNew->zVarname = (char *)&pNew[1]; 167 pNew->zScript = (char *)&pNew->zVarname[nVarname+1]; 168 memcpy(pNew->zVarname, zVarname, nVarname+1); 169 memcpy(pNew->zScript, zScript, nScript+1); 170 pNew->parent = Tcl_GetCurrentThread(); 171 pNew->interp = interp; 172 173 rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags); 174 if( rc!=TCL_OK ){ 175 Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0); 176 ckfree((char *)pNew); 177 return TCL_ERROR; 178 } 179 180 return TCL_OK; 181 } 182 183 /* 184 ** sqlthread parent SCRIPT 185 ** 186 ** This can be called by spawned threads only. It sends the specified 187 ** script back to the parent thread for execution. The result of 188 ** evaluating the SCRIPT is returned. The parent thread must enter 189 ** the event loop for this to work - otherwise the caller will 190 ** block indefinitely. 191 ** 192 ** NOTE: At the moment, this doesn't work. FIXME. 193 */ 194 static int sqlthread_parent( 195 ClientData clientData, 196 Tcl_Interp *interp, 197 int objc, 198 Tcl_Obj *CONST objv[] 199 ){ 200 EvalEvent *pEvent; 201 char *zMsg; 202 int nMsg; 203 SqlThread *p = (SqlThread *)clientData; 204 205 assert(objc==3); 206 if( p==0 ){ 207 Tcl_AppendResult(interp, "no parent thread", 0); 208 return TCL_ERROR; 209 } 210 211 zMsg = Tcl_GetStringFromObj(objv[2], &nMsg); 212 pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1); 213 pEvent->base.nextPtr = 0; 214 pEvent->base.proc = tclScriptEvent; 215 pEvent->zScript = (char *)&pEvent[1]; 216 memcpy(pEvent->zScript, zMsg, nMsg+1); 217 pEvent->interp = p->interp; 218 Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL); 219 Tcl_ThreadAlert(p->parent); 220 221 return TCL_OK; 222 } 223 224 static int xBusy(void *pArg, int nBusy){ 225 sqlite3_sleep(50); 226 return 1; /* Try again... */ 227 } 228 229 /* 230 ** sqlthread open 231 ** 232 ** Open a database handle and return the string representation of 233 ** the pointer value. 234 */ 235 static int sqlthread_open( 236 ClientData clientData, 237 Tcl_Interp *interp, 238 int objc, 239 Tcl_Obj *CONST objv[] 240 ){ 241 int sqlite3TestMakePointerStr(Tcl_Interp *interp, char *zPtr, void *p); 242 243 const char *zFilename; 244 sqlite3 *db; 245 int rc; 246 char zBuf[100]; 247 extern void Md5_Register(sqlite3*); 248 249 zFilename = Tcl_GetString(objv[2]); 250 rc = sqlite3_open(zFilename, &db); 251 Md5_Register(db); 252 sqlite3_busy_handler(db, xBusy, 0); 253 254 if( sqlite3TestMakePointerStr(interp, zBuf, db) ) return TCL_ERROR; 255 Tcl_AppendResult(interp, zBuf, 0); 256 257 return TCL_OK; 258 } 259 260 261 /* 262 ** sqlthread open 263 ** 264 ** Return the current thread-id (Tcl_GetCurrentThread()) cast to 265 ** an integer. 266 */ 267 static int sqlthread_id( 268 ClientData clientData, 269 Tcl_Interp *interp, 270 int objc, 271 Tcl_Obj *CONST objv[] 272 ){ 273 Tcl_ThreadId id = Tcl_GetCurrentThread(); 274 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id)); 275 return TCL_OK; 276 } 277 278 279 /* 280 ** Dispatch routine for the sub-commands of [sqlthread]. 281 */ 282 static int sqlthread_proc( 283 ClientData clientData, 284 Tcl_Interp *interp, 285 int objc, 286 Tcl_Obj *CONST objv[] 287 ){ 288 struct SubCommand { 289 char *zName; 290 Tcl_ObjCmdProc *xProc; 291 int nArg; 292 char *zUsage; 293 } aSub[] = { 294 {"parent", sqlthread_parent, 1, "SCRIPT"}, 295 {"spawn", sqlthread_spawn, 2, "VARNAME SCRIPT"}, 296 {"open", sqlthread_open, 1, "DBNAME"}, 297 {"id", sqlthread_id, 0, ""}, 298 {0, 0, 0} 299 }; 300 struct SubCommand *pSub; 301 int rc; 302 int iIndex; 303 304 if( objc<2 ){ 305 Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND"); 306 return TCL_ERROR; 307 } 308 309 rc = Tcl_GetIndexFromObjStruct( 310 interp, objv[1], aSub, sizeof(aSub[0]), "sub-command", 0, &iIndex 311 ); 312 if( rc!=TCL_OK ) return rc; 313 pSub = &aSub[iIndex]; 314 315 if( objc!=(pSub->nArg+2) ){ 316 Tcl_WrongNumArgs(interp, 2, objv, pSub->zUsage); 317 return TCL_ERROR; 318 } 319 320 return pSub->xProc(clientData, interp, objc, objv); 321 } 322 323 /* 324 ** The [clock_seconds] command. This is more or less the same as the 325 ** regular tcl [clock seconds], except that it is available in testfixture 326 ** when linked against both Tcl 8.4 and 8.5. Because [clock seconds] is 327 ** implemented as a script in Tcl 8.5, it is not usually available to 328 ** testfixture. 329 */ 330 static int clock_seconds_proc( 331 ClientData clientData, 332 Tcl_Interp *interp, 333 int objc, 334 Tcl_Obj *CONST objv[] 335 ){ 336 Tcl_Time now; 337 Tcl_GetTime(&now); 338 Tcl_SetObjResult(interp, Tcl_NewIntObj(now.sec)); 339 return TCL_OK; 340 } 341 342 /* 343 ** Register commands with the TCL interpreter. 344 */ 345 int SqlitetestThread_Init(Tcl_Interp *interp){ 346 Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, 0, 0); 347 Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0); 348 return TCL_OK; 349 } 350 #else 351 int SqlitetestThread_Init(Tcl_Interp *interp){ 352 return TCL_OK; 353 } 354 #endif 355