1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/SRC/test_thread.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,354 @@
1.4 +/*
1.5 +** 2007 September 9
1.6 +**
1.7 +** The author disclaims copyright to this source code. In place of
1.8 +** a legal notice, here is a blessing:
1.9 +**
1.10 +** May you do good and not evil.
1.11 +** May you find forgiveness for yourself and forgive others.
1.12 +** May you share freely, never taking more than you give.
1.13 +**
1.14 +*************************************************************************
1.15 +**
1.16 +** This file contains the implementation of some Tcl commands used to
1.17 +** test that sqlite3 database handles may be concurrently accessed by
1.18 +** multiple threads. Right now this only works on unix.
1.19 +**
1.20 +** $Id: test_thread.c,v 1.8 2008/08/28 13:55:10 danielk1977 Exp $
1.21 +*/
1.22 +
1.23 +#include "sqliteInt.h"
1.24 +#include "tcl.h"
1.25 +
1.26 +#if SQLITE_THREADSAFE && defined(TCL_THREADS)
1.27 +
1.28 +#include <errno.h>
1.29 +#include <unistd.h>
1.30 +
1.31 +/*
1.32 +** One of these is allocated for each thread created by [sqlthread spawn].
1.33 +*/
1.34 +typedef struct SqlThread SqlThread;
1.35 +struct SqlThread {
1.36 + Tcl_ThreadId parent; /* Thread id of parent thread */
1.37 + Tcl_Interp *interp; /* Parent interpreter */
1.38 + char *zScript; /* The script to execute. */
1.39 + char *zVarname; /* Varname in parent script */
1.40 +};
1.41 +
1.42 +/*
1.43 +** A custom Tcl_Event type used by this module. When the event is
1.44 +** handled, script zScript is evaluated in interpreter interp. If
1.45 +** the evaluation throws an exception (returns TCL_ERROR), then the
1.46 +** error is handled by Tcl_BackgroundError(). If no error occurs,
1.47 +** the result is simply discarded.
1.48 +*/
1.49 +typedef struct EvalEvent EvalEvent;
1.50 +struct EvalEvent {
1.51 + Tcl_Event base; /* Base class of type Tcl_Event */
1.52 + char *zScript; /* The script to execute. */
1.53 + Tcl_Interp *interp; /* The interpreter to execute it in. */
1.54 +};
1.55 +
1.56 +static Tcl_ObjCmdProc sqlthread_proc;
1.57 +static Tcl_ObjCmdProc clock_seconds_proc;
1.58 +int Sqlitetest1_Init(Tcl_Interp *);
1.59 +
1.60 +/*
1.61 +** Handler for events of type EvalEvent.
1.62 +*/
1.63 +static int tclScriptEvent(Tcl_Event *evPtr, int flags){
1.64 + int rc;
1.65 + EvalEvent *p = (EvalEvent *)evPtr;
1.66 + rc = Tcl_Eval(p->interp, p->zScript);
1.67 + if( rc!=TCL_OK ){
1.68 + Tcl_BackgroundError(p->interp);
1.69 + }
1.70 + return 1;
1.71 +}
1.72 +
1.73 +/*
1.74 +** Register an EvalEvent to evaluate the script pScript in the
1.75 +** parent interpreter/thread of SqlThread p.
1.76 +*/
1.77 +static void postToParent(SqlThread *p, Tcl_Obj *pScript){
1.78 + EvalEvent *pEvent;
1.79 + char *zMsg;
1.80 + int nMsg;
1.81 +
1.82 + zMsg = Tcl_GetStringFromObj(pScript, &nMsg);
1.83 + pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);
1.84 + pEvent->base.nextPtr = 0;
1.85 + pEvent->base.proc = tclScriptEvent;
1.86 + pEvent->zScript = (char *)&pEvent[1];
1.87 + memcpy(pEvent->zScript, zMsg, nMsg+1);
1.88 + pEvent->interp = p->interp;
1.89 +
1.90 + Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);
1.91 + Tcl_ThreadAlert(p->parent);
1.92 +}
1.93 +
1.94 +/*
1.95 +** The main function for threads created with [sqlthread spawn].
1.96 +*/
1.97 +static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){
1.98 + Tcl_Interp *interp;
1.99 + Tcl_Obj *pRes;
1.100 + Tcl_Obj *pList;
1.101 + int rc;
1.102 +
1.103 + SqlThread *p = (SqlThread *)pSqlThread;
1.104 +
1.105 + interp = Tcl_CreateInterp();
1.106 + Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
1.107 + Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0);
1.108 + Sqlitetest1_Init(interp);
1.109 +
1.110 + rc = Tcl_Eval(interp, p->zScript);
1.111 + pRes = Tcl_GetObjResult(interp);
1.112 + pList = Tcl_NewObj();
1.113 + Tcl_IncrRefCount(pList);
1.114 + Tcl_IncrRefCount(pRes);
1.115 +
1.116 + if( rc!=TCL_OK ){
1.117 + Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));
1.118 + Tcl_ListObjAppendElement(interp, pList, pRes);
1.119 + postToParent(p, pList);
1.120 + Tcl_DecrRefCount(pList);
1.121 + pList = Tcl_NewObj();
1.122 + }
1.123 +
1.124 + Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));
1.125 + Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
1.126 + Tcl_ListObjAppendElement(interp, pList, pRes);
1.127 + postToParent(p, pList);
1.128 +
1.129 + ckfree((void *)p);
1.130 + Tcl_DecrRefCount(pList);
1.131 + Tcl_DecrRefCount(pRes);
1.132 + Tcl_DeleteInterp(interp);
1.133 + return;
1.134 +}
1.135 +
1.136 +/*
1.137 +** sqlthread spawn VARNAME SCRIPT
1.138 +**
1.139 +** Spawn a new thread with its own Tcl interpreter and run the
1.140 +** specified SCRIPT(s) in it. The thread terminates after running
1.141 +** the script. The result of the script is stored in the variable
1.142 +** VARNAME.
1.143 +**
1.144 +** The caller can wait for the script to terminate using [vwait VARNAME].
1.145 +*/
1.146 +static int sqlthread_spawn(
1.147 + ClientData clientData,
1.148 + Tcl_Interp *interp,
1.149 + int objc,
1.150 + Tcl_Obj *CONST objv[]
1.151 +){
1.152 + Tcl_ThreadId x;
1.153 + SqlThread *pNew;
1.154 + int rc;
1.155 +
1.156 + int nVarname; char *zVarname;
1.157 + int nScript; char *zScript;
1.158 +
1.159 + /* Parameters for thread creation */
1.160 + const int nStack = TCL_THREAD_STACK_DEFAULT;
1.161 + const int flags = TCL_THREAD_NOFLAGS;
1.162 +
1.163 + assert(objc==4);
1.164 +
1.165 + zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);
1.166 + zScript = Tcl_GetStringFromObj(objv[3], &nScript);
1.167 +
1.168 + pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2);
1.169 + pNew->zVarname = (char *)&pNew[1];
1.170 + pNew->zScript = (char *)&pNew->zVarname[nVarname+1];
1.171 + memcpy(pNew->zVarname, zVarname, nVarname+1);
1.172 + memcpy(pNew->zScript, zScript, nScript+1);
1.173 + pNew->parent = Tcl_GetCurrentThread();
1.174 + pNew->interp = interp;
1.175 +
1.176 + rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags);
1.177 + if( rc!=TCL_OK ){
1.178 + Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0);
1.179 + ckfree((char *)pNew);
1.180 + return TCL_ERROR;
1.181 + }
1.182 +
1.183 + return TCL_OK;
1.184 +}
1.185 +
1.186 +/*
1.187 +** sqlthread parent SCRIPT
1.188 +**
1.189 +** This can be called by spawned threads only. It sends the specified
1.190 +** script back to the parent thread for execution. The result of
1.191 +** evaluating the SCRIPT is returned. The parent thread must enter
1.192 +** the event loop for this to work - otherwise the caller will
1.193 +** block indefinitely.
1.194 +**
1.195 +** NOTE: At the moment, this doesn't work. FIXME.
1.196 +*/
1.197 +static int sqlthread_parent(
1.198 + ClientData clientData,
1.199 + Tcl_Interp *interp,
1.200 + int objc,
1.201 + Tcl_Obj *CONST objv[]
1.202 +){
1.203 + EvalEvent *pEvent;
1.204 + char *zMsg;
1.205 + int nMsg;
1.206 + SqlThread *p = (SqlThread *)clientData;
1.207 +
1.208 + assert(objc==3);
1.209 + if( p==0 ){
1.210 + Tcl_AppendResult(interp, "no parent thread", 0);
1.211 + return TCL_ERROR;
1.212 + }
1.213 +
1.214 + zMsg = Tcl_GetStringFromObj(objv[2], &nMsg);
1.215 + pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);
1.216 + pEvent->base.nextPtr = 0;
1.217 + pEvent->base.proc = tclScriptEvent;
1.218 + pEvent->zScript = (char *)&pEvent[1];
1.219 + memcpy(pEvent->zScript, zMsg, nMsg+1);
1.220 + pEvent->interp = p->interp;
1.221 + Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);
1.222 + Tcl_ThreadAlert(p->parent);
1.223 +
1.224 + return TCL_OK;
1.225 +}
1.226 +
1.227 +static int xBusy(void *pArg, int nBusy){
1.228 + sqlite3_sleep(50);
1.229 + return 1; /* Try again... */
1.230 +}
1.231 +
1.232 +/*
1.233 +** sqlthread open
1.234 +**
1.235 +** Open a database handle and return the string representation of
1.236 +** the pointer value.
1.237 +*/
1.238 +static int sqlthread_open(
1.239 + ClientData clientData,
1.240 + Tcl_Interp *interp,
1.241 + int objc,
1.242 + Tcl_Obj *CONST objv[]
1.243 +){
1.244 + int sqlite3TestMakePointerStr(Tcl_Interp *interp, char *zPtr, void *p);
1.245 +
1.246 + const char *zFilename;
1.247 + sqlite3 *db;
1.248 + int rc;
1.249 + char zBuf[100];
1.250 + extern void Md5_Register(sqlite3*);
1.251 +
1.252 + zFilename = Tcl_GetString(objv[2]);
1.253 + rc = sqlite3_open(zFilename, &db);
1.254 + Md5_Register(db);
1.255 + sqlite3_busy_handler(db, xBusy, 0);
1.256 +
1.257 + if( sqlite3TestMakePointerStr(interp, zBuf, db) ) return TCL_ERROR;
1.258 + Tcl_AppendResult(interp, zBuf, 0);
1.259 +
1.260 + return TCL_OK;
1.261 +}
1.262 +
1.263 +
1.264 +/*
1.265 +** sqlthread open
1.266 +**
1.267 +** Return the current thread-id (Tcl_GetCurrentThread()) cast to
1.268 +** an integer.
1.269 +*/
1.270 +static int sqlthread_id(
1.271 + ClientData clientData,
1.272 + Tcl_Interp *interp,
1.273 + int objc,
1.274 + Tcl_Obj *CONST objv[]
1.275 +){
1.276 + Tcl_ThreadId id = Tcl_GetCurrentThread();
1.277 + Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id));
1.278 + return TCL_OK;
1.279 +}
1.280 +
1.281 +
1.282 +/*
1.283 +** Dispatch routine for the sub-commands of [sqlthread].
1.284 +*/
1.285 +static int sqlthread_proc(
1.286 + ClientData clientData,
1.287 + Tcl_Interp *interp,
1.288 + int objc,
1.289 + Tcl_Obj *CONST objv[]
1.290 +){
1.291 + struct SubCommand {
1.292 + char *zName;
1.293 + Tcl_ObjCmdProc *xProc;
1.294 + int nArg;
1.295 + char *zUsage;
1.296 + } aSub[] = {
1.297 + {"parent", sqlthread_parent, 1, "SCRIPT"},
1.298 + {"spawn", sqlthread_spawn, 2, "VARNAME SCRIPT"},
1.299 + {"open", sqlthread_open, 1, "DBNAME"},
1.300 + {"id", sqlthread_id, 0, ""},
1.301 + {0, 0, 0}
1.302 + };
1.303 + struct SubCommand *pSub;
1.304 + int rc;
1.305 + int iIndex;
1.306 +
1.307 + if( objc<2 ){
1.308 + Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND");
1.309 + return TCL_ERROR;
1.310 + }
1.311 +
1.312 + rc = Tcl_GetIndexFromObjStruct(
1.313 + interp, objv[1], aSub, sizeof(aSub[0]), "sub-command", 0, &iIndex
1.314 + );
1.315 + if( rc!=TCL_OK ) return rc;
1.316 + pSub = &aSub[iIndex];
1.317 +
1.318 + if( objc!=(pSub->nArg+2) ){
1.319 + Tcl_WrongNumArgs(interp, 2, objv, pSub->zUsage);
1.320 + return TCL_ERROR;
1.321 + }
1.322 +
1.323 + return pSub->xProc(clientData, interp, objc, objv);
1.324 +}
1.325 +
1.326 +/*
1.327 +** The [clock_seconds] command. This is more or less the same as the
1.328 +** regular tcl [clock seconds], except that it is available in testfixture
1.329 +** when linked against both Tcl 8.4 and 8.5. Because [clock seconds] is
1.330 +** implemented as a script in Tcl 8.5, it is not usually available to
1.331 +** testfixture.
1.332 +*/
1.333 +static int clock_seconds_proc(
1.334 + ClientData clientData,
1.335 + Tcl_Interp *interp,
1.336 + int objc,
1.337 + Tcl_Obj *CONST objv[]
1.338 +){
1.339 + Tcl_Time now;
1.340 + Tcl_GetTime(&now);
1.341 + Tcl_SetObjResult(interp, Tcl_NewIntObj(now.sec));
1.342 + return TCL_OK;
1.343 +}
1.344 +
1.345 +/*
1.346 +** Register commands with the TCL interpreter.
1.347 +*/
1.348 +int SqlitetestThread_Init(Tcl_Interp *interp){
1.349 + Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, 0, 0);
1.350 + Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
1.351 + return TCL_OK;
1.352 +}
1.353 +#else
1.354 +int SqlitetestThread_Init(Tcl_Interp *interp){
1.355 + return TCL_OK;
1.356 +}
1.357 +#endif