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