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