sl@0: /*
sl@0: ** 2007 September 9
sl@0: **
sl@0: ** The author disclaims copyright to this source code.  In place of
sl@0: ** a legal notice, here is a blessing:
sl@0: **
sl@0: **    May you do good and not evil.
sl@0: **    May you find forgiveness for yourself and forgive others.
sl@0: **    May you share freely, never taking more than you give.
sl@0: **
sl@0: *************************************************************************
sl@0: **
sl@0: ** This file contains the implementation of some Tcl commands used to
sl@0: ** test that sqlite3 database handles may be concurrently accessed by 
sl@0: ** multiple threads. Right now this only works on unix.
sl@0: **
sl@0: ** $Id: test_thread.c,v 1.8 2008/08/28 13:55:10 danielk1977 Exp $
sl@0: */
sl@0: 
sl@0: #include "sqliteInt.h"
sl@0: #include "tcl.h"
sl@0: 
sl@0: #if SQLITE_THREADSAFE && defined(TCL_THREADS)
sl@0: 
sl@0: #include <errno.h>
sl@0: #include <unistd.h>
sl@0: 
sl@0: /*
sl@0: ** One of these is allocated for each thread created by [sqlthread spawn].
sl@0: */
sl@0: typedef struct SqlThread SqlThread;
sl@0: struct SqlThread {
sl@0:   Tcl_ThreadId parent;     /* Thread id of parent thread */
sl@0:   Tcl_Interp *interp;      /* Parent interpreter */
sl@0:   char *zScript;           /* The script to execute. */
sl@0:   char *zVarname;          /* Varname in parent script */
sl@0: };
sl@0: 
sl@0: /*
sl@0: ** A custom Tcl_Event type used by this module. When the event is
sl@0: ** handled, script zScript is evaluated in interpreter interp. If
sl@0: ** the evaluation throws an exception (returns TCL_ERROR), then the
sl@0: ** error is handled by Tcl_BackgroundError(). If no error occurs,
sl@0: ** the result is simply discarded.
sl@0: */
sl@0: typedef struct EvalEvent EvalEvent;
sl@0: struct EvalEvent {
sl@0:   Tcl_Event base;          /* Base class of type Tcl_Event */
sl@0:   char *zScript;           /* The script to execute. */
sl@0:   Tcl_Interp *interp;      /* The interpreter to execute it in. */
sl@0: };
sl@0: 
sl@0: static Tcl_ObjCmdProc sqlthread_proc;
sl@0: static Tcl_ObjCmdProc clock_seconds_proc;
sl@0: int Sqlitetest1_Init(Tcl_Interp *);
sl@0: 
sl@0: /*
sl@0: ** Handler for events of type EvalEvent.
sl@0: */
sl@0: static int tclScriptEvent(Tcl_Event *evPtr, int flags){
sl@0:   int rc;
sl@0:   EvalEvent *p = (EvalEvent *)evPtr;
sl@0:   rc = Tcl_Eval(p->interp, p->zScript);
sl@0:   if( rc!=TCL_OK ){
sl@0:     Tcl_BackgroundError(p->interp);
sl@0:   }
sl@0:   return 1;
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** Register an EvalEvent to evaluate the script pScript in the
sl@0: ** parent interpreter/thread of SqlThread p.
sl@0: */
sl@0: static void postToParent(SqlThread *p, Tcl_Obj *pScript){
sl@0:   EvalEvent *pEvent;
sl@0:   char *zMsg;
sl@0:   int nMsg;
sl@0: 
sl@0:   zMsg = Tcl_GetStringFromObj(pScript, &nMsg); 
sl@0:   pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);
sl@0:   pEvent->base.nextPtr = 0;
sl@0:   pEvent->base.proc = tclScriptEvent;
sl@0:   pEvent->zScript = (char *)&pEvent[1];
sl@0:   memcpy(pEvent->zScript, zMsg, nMsg+1);
sl@0:   pEvent->interp = p->interp;
sl@0: 
sl@0:   Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);
sl@0:   Tcl_ThreadAlert(p->parent);
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** The main function for threads created with [sqlthread spawn].
sl@0: */
sl@0: static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){
sl@0:   Tcl_Interp *interp;
sl@0:   Tcl_Obj *pRes;
sl@0:   Tcl_Obj *pList;
sl@0:   int rc;
sl@0: 
sl@0:   SqlThread *p = (SqlThread *)pSqlThread;
sl@0: 
sl@0:   interp = Tcl_CreateInterp();
sl@0:   Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
sl@0:   Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0);
sl@0:   Sqlitetest1_Init(interp);
sl@0: 
sl@0:   rc = Tcl_Eval(interp, p->zScript);
sl@0:   pRes = Tcl_GetObjResult(interp);
sl@0:   pList = Tcl_NewObj();
sl@0:   Tcl_IncrRefCount(pList);
sl@0:   Tcl_IncrRefCount(pRes);
sl@0: 
sl@0:   if( rc!=TCL_OK ){
sl@0:     Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));
sl@0:     Tcl_ListObjAppendElement(interp, pList, pRes);
sl@0:     postToParent(p, pList);
sl@0:     Tcl_DecrRefCount(pList);
sl@0:     pList = Tcl_NewObj();
sl@0:   }
sl@0: 
sl@0:   Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));
sl@0:   Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
sl@0:   Tcl_ListObjAppendElement(interp, pList, pRes);
sl@0:   postToParent(p, pList);
sl@0: 
sl@0:   ckfree((void *)p);
sl@0:   Tcl_DecrRefCount(pList);
sl@0:   Tcl_DecrRefCount(pRes);
sl@0:   Tcl_DeleteInterp(interp);
sl@0:   return;
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** sqlthread spawn VARNAME SCRIPT
sl@0: **
sl@0: **     Spawn a new thread with its own Tcl interpreter and run the
sl@0: **     specified SCRIPT(s) in it. The thread terminates after running
sl@0: **     the script. The result of the script is stored in the variable
sl@0: **     VARNAME.
sl@0: **
sl@0: **     The caller can wait for the script to terminate using [vwait VARNAME].
sl@0: */
sl@0: static int sqlthread_spawn(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   Tcl_ThreadId x;
sl@0:   SqlThread *pNew;
sl@0:   int rc;
sl@0: 
sl@0:   int nVarname; char *zVarname;
sl@0:   int nScript; char *zScript;
sl@0: 
sl@0:   /* Parameters for thread creation */
sl@0:   const int nStack = TCL_THREAD_STACK_DEFAULT;
sl@0:   const int flags = TCL_THREAD_NOFLAGS;
sl@0: 
sl@0:   assert(objc==4);
sl@0: 
sl@0:   zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);
sl@0:   zScript = Tcl_GetStringFromObj(objv[3], &nScript);
sl@0: 
sl@0:   pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2);
sl@0:   pNew->zVarname = (char *)&pNew[1];
sl@0:   pNew->zScript = (char *)&pNew->zVarname[nVarname+1];
sl@0:   memcpy(pNew->zVarname, zVarname, nVarname+1);
sl@0:   memcpy(pNew->zScript, zScript, nScript+1);
sl@0:   pNew->parent = Tcl_GetCurrentThread();
sl@0:   pNew->interp = interp;
sl@0: 
sl@0:   rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags);
sl@0:   if( rc!=TCL_OK ){
sl@0:     Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0);
sl@0:     ckfree((char *)pNew);
sl@0:     return TCL_ERROR;
sl@0:   }
sl@0: 
sl@0:   return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** sqlthread parent SCRIPT
sl@0: **
sl@0: **     This can be called by spawned threads only. It sends the specified
sl@0: **     script back to the parent thread for execution. The result of
sl@0: **     evaluating the SCRIPT is returned. The parent thread must enter
sl@0: **     the event loop for this to work - otherwise the caller will
sl@0: **     block indefinitely.
sl@0: **
sl@0: **     NOTE: At the moment, this doesn't work. FIXME.
sl@0: */
sl@0: static int sqlthread_parent(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   EvalEvent *pEvent;
sl@0:   char *zMsg;
sl@0:   int nMsg;
sl@0:   SqlThread *p = (SqlThread *)clientData;
sl@0: 
sl@0:   assert(objc==3);
sl@0:   if( p==0 ){
sl@0:     Tcl_AppendResult(interp, "no parent thread", 0);
sl@0:     return TCL_ERROR;
sl@0:   }
sl@0: 
sl@0:   zMsg = Tcl_GetStringFromObj(objv[2], &nMsg);
sl@0:   pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);
sl@0:   pEvent->base.nextPtr = 0;
sl@0:   pEvent->base.proc = tclScriptEvent;
sl@0:   pEvent->zScript = (char *)&pEvent[1];
sl@0:   memcpy(pEvent->zScript, zMsg, nMsg+1);
sl@0:   pEvent->interp = p->interp;
sl@0:   Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);
sl@0:   Tcl_ThreadAlert(p->parent);
sl@0: 
sl@0:   return TCL_OK;
sl@0: }
sl@0: 
sl@0: static int xBusy(void *pArg, int nBusy){
sl@0:   sqlite3_sleep(50);
sl@0:   return 1;             /* Try again... */
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** sqlthread open
sl@0: **
sl@0: **     Open a database handle and return the string representation of
sl@0: **     the pointer value.
sl@0: */
sl@0: static int sqlthread_open(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   int sqlite3TestMakePointerStr(Tcl_Interp *interp, char *zPtr, void *p);
sl@0: 
sl@0:   const char *zFilename;
sl@0:   sqlite3 *db;
sl@0:   int rc;
sl@0:   char zBuf[100];
sl@0:   extern void Md5_Register(sqlite3*);
sl@0: 
sl@0:   zFilename = Tcl_GetString(objv[2]);
sl@0:   rc = sqlite3_open(zFilename, &db);
sl@0:   Md5_Register(db);
sl@0:   sqlite3_busy_handler(db, xBusy, 0);
sl@0:   
sl@0:   if( sqlite3TestMakePointerStr(interp, zBuf, db) ) return TCL_ERROR;
sl@0:   Tcl_AppendResult(interp, zBuf, 0);
sl@0: 
sl@0:   return TCL_OK;
sl@0: }
sl@0: 
sl@0: 
sl@0: /*
sl@0: ** sqlthread open
sl@0: **
sl@0: **     Return the current thread-id (Tcl_GetCurrentThread()) cast to
sl@0: **     an integer.
sl@0: */
sl@0: static int sqlthread_id(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   Tcl_ThreadId id = Tcl_GetCurrentThread();
sl@0:   Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id));
sl@0:   return TCL_OK;
sl@0: }
sl@0: 
sl@0: 
sl@0: /*
sl@0: ** Dispatch routine for the sub-commands of [sqlthread].
sl@0: */
sl@0: static int sqlthread_proc(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   struct SubCommand {
sl@0:     char *zName;
sl@0:     Tcl_ObjCmdProc *xProc;
sl@0:     int nArg;
sl@0:     char *zUsage;
sl@0:   } aSub[] = {
sl@0:     {"parent", sqlthread_parent, 1, "SCRIPT"},
sl@0:     {"spawn",  sqlthread_spawn,  2, "VARNAME SCRIPT"},
sl@0:     {"open",   sqlthread_open,   1, "DBNAME"},
sl@0:     {"id",     sqlthread_id,     0, ""},
sl@0:     {0, 0, 0}
sl@0:   };
sl@0:   struct SubCommand *pSub;
sl@0:   int rc;
sl@0:   int iIndex;
sl@0: 
sl@0:   if( objc<2 ){
sl@0:     Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND");
sl@0:     return TCL_ERROR;
sl@0:   }
sl@0: 
sl@0:   rc = Tcl_GetIndexFromObjStruct(
sl@0:       interp, objv[1], aSub, sizeof(aSub[0]), "sub-command", 0, &iIndex
sl@0:   );
sl@0:   if( rc!=TCL_OK ) return rc;
sl@0:   pSub = &aSub[iIndex];
sl@0: 
sl@0:   if( objc!=(pSub->nArg+2) ){
sl@0:     Tcl_WrongNumArgs(interp, 2, objv, pSub->zUsage);
sl@0:     return TCL_ERROR;
sl@0:   }
sl@0: 
sl@0:   return pSub->xProc(clientData, interp, objc, objv);
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** The [clock_seconds] command. This is more or less the same as the
sl@0: ** regular tcl [clock seconds], except that it is available in testfixture
sl@0: ** when linked against both Tcl 8.4 and 8.5. Because [clock seconds] is
sl@0: ** implemented as a script in Tcl 8.5, it is not usually available to
sl@0: ** testfixture.
sl@0: */ 
sl@0: static int clock_seconds_proc(
sl@0:   ClientData clientData,
sl@0:   Tcl_Interp *interp,
sl@0:   int objc,
sl@0:   Tcl_Obj *CONST objv[]
sl@0: ){
sl@0:   Tcl_Time now;
sl@0:   Tcl_GetTime(&now);
sl@0:   Tcl_SetObjResult(interp, Tcl_NewIntObj(now.sec));
sl@0:   return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0: ** Register commands with the TCL interpreter.
sl@0: */
sl@0: int SqlitetestThread_Init(Tcl_Interp *interp){
sl@0:   Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, 0, 0);
sl@0:   Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
sl@0:   return TCL_OK;
sl@0: }
sl@0: #else
sl@0: int SqlitetestThread_Init(Tcl_Interp *interp){
sl@0:   return TCL_OK;
sl@0: }
sl@0: #endif