/*

** 2007 September 9

**

** The author disclaims copyright to this source code.  In place of

** a legal notice, here is a blessing:

**

**    May you do good and not evil.

**    May you find forgiveness for yourself and forgive others.

**    May you share freely, never taking more than you give.

**

*************************************************************************

**

** This file contains the implementation of some Tcl commands used to

** test that sqlite3 database handles may be concurrently accessed by 

** multiple threads. Right now this only works on unix.

**

** $Id: test_thread.c,v 1.8 2008/08/28 13:55:10 danielk1977 Exp $

*/

#include "sqliteInt.h"

#include "tcl.h"

#if SQLITE_THREADSAFE && defined(TCL_THREADS)

#include <errno.h>

#include <unistd.h>

/*

** One of these is allocated for each thread created by [sqlthread spawn].

*/

typedef struct SqlThread SqlThread;

struct SqlThread {

  Tcl_ThreadId parent;     /* Thread id of parent thread */

  Tcl_Interp *interp;      /* Parent interpreter */

  char *zScript;           /* The script to execute. */

  char *zVarname;          /* Varname in parent script */

};

/*

** A custom Tcl_Event type used by this module. When the event is

** handled, script zScript is evaluated in interpreter interp. If

** the evaluation throws an exception (returns TCL_ERROR), then the

** error is handled by Tcl_BackgroundError(). If no error occurs,

** the result is simply discarded.

*/

typedef struct EvalEvent EvalEvent;

struct EvalEvent {

  Tcl_Event base;          /* Base class of type Tcl_Event */

  char *zScript;           /* The script to execute. */

  Tcl_Interp *interp;      /* The interpreter to execute it in. */

};

static Tcl_ObjCmdProc sqlthread_proc;

static Tcl_ObjCmdProc clock_seconds_proc;

int Sqlitetest1_Init(Tcl_Interp *);

/*

** Handler for events of type EvalEvent.

*/

static int tclScriptEvent(Tcl_Event *evPtr, int flags){

  int rc;

  EvalEvent *p = (EvalEvent *)evPtr;

  rc = Tcl_Eval(p->interp, p->zScript);

  if( rc!=TCL_OK ){

    Tcl_BackgroundError(p->interp);

  }

  return 1;

}

/*

** Register an EvalEvent to evaluate the script pScript in the

** parent interpreter/thread of SqlThread p.

*/

static void postToParent(SqlThread *p, Tcl_Obj *pScript){

  EvalEvent *pEvent;

  char *zMsg;

  int nMsg;

  zMsg = Tcl_GetStringFromObj(pScript, &nMsg); 

  pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);

  pEvent->base.nextPtr = 0;

  pEvent->base.proc = tclScriptEvent;

  pEvent->zScript = (char *)&pEvent[1];

  memcpy(pEvent->zScript, zMsg, nMsg+1);

  pEvent->interp = p->interp;

  Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);

  Tcl_ThreadAlert(p->parent);

}

/*

** The main function for threads created with [sqlthread spawn].

*/

static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){

  Tcl_Interp *interp;

  Tcl_Obj *pRes;

  Tcl_Obj *pList;

  int rc;

  SqlThread *p = (SqlThread *)pSqlThread;

  interp = Tcl_CreateInterp();

  Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);

  Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0);

  Sqlitetest1_Init(interp);

  rc = Tcl_Eval(interp, p->zScript);

  pRes = Tcl_GetObjResult(interp);

  pList = Tcl_NewObj();

  Tcl_IncrRefCount(pList);

  Tcl_IncrRefCount(pRes);

  if( rc!=TCL_OK ){

    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));

    Tcl_ListObjAppendElement(interp, pList, pRes);

    postToParent(p, pList);

    Tcl_DecrRefCount(pList);

    pList = Tcl_NewObj();

  }

  Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));

  Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));

  Tcl_ListObjAppendElement(interp, pList, pRes);

  postToParent(p, pList);

  ckfree((void *)p);

  Tcl_DecrRefCount(pList);

  Tcl_DecrRefCount(pRes);

  Tcl_DeleteInterp(interp);

  return;

}

/*

** sqlthread spawn VARNAME SCRIPT

**

**     Spawn a new thread with its own Tcl interpreter and run the

**     specified SCRIPT(s) in it. The thread terminates after running

**     the script. The result of the script is stored in the variable

**     VARNAME.

**

**     The caller can wait for the script to terminate using [vwait VARNAME].

*/

static int sqlthread_spawn(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  Tcl_ThreadId x;

  SqlThread *pNew;

  int rc;

  int nVarname; char *zVarname;

  int nScript; char *zScript;

  /* Parameters for thread creation */

  const int nStack = TCL_THREAD_STACK_DEFAULT;

  const int flags = TCL_THREAD_NOFLAGS;

  assert(objc==4);

  zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);

  zScript = Tcl_GetStringFromObj(objv[3], &nScript);

  pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2);

  pNew->zVarname = (char *)&pNew[1];

  pNew->zScript = (char *)&pNew->zVarname[nVarname+1];

  memcpy(pNew->zVarname, zVarname, nVarname+1);

  memcpy(pNew->zScript, zScript, nScript+1);

  pNew->parent = Tcl_GetCurrentThread();

  pNew->interp = interp;

  rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags);

  if( rc!=TCL_OK ){

    Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0);

    ckfree((char *)pNew);

    return TCL_ERROR;

  }

  return TCL_OK;

}

/*

** sqlthread parent SCRIPT

**

**     This can be called by spawned threads only. It sends the specified

**     script back to the parent thread for execution. The result of

**     evaluating the SCRIPT is returned. The parent thread must enter

**     the event loop for this to work - otherwise the caller will

**     block indefinitely.

**

**     NOTE: At the moment, this doesn't work. FIXME.

*/

static int sqlthread_parent(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  EvalEvent *pEvent;

  char *zMsg;

  int nMsg;

  SqlThread *p = (SqlThread *)clientData;

  assert(objc==3);

  if( p==0 ){

    Tcl_AppendResult(interp, "no parent thread", 0);

    return TCL_ERROR;

  }

  zMsg = Tcl_GetStringFromObj(objv[2], &nMsg);

  pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);

  pEvent->base.nextPtr = 0;

  pEvent->base.proc = tclScriptEvent;

  pEvent->zScript = (char *)&pEvent[1];

  memcpy(pEvent->zScript, zMsg, nMsg+1);

  pEvent->interp = p->interp;

  Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);

  Tcl_ThreadAlert(p->parent);

  return TCL_OK;

}

static int xBusy(void *pArg, int nBusy){

  sqlite3_sleep(50);

  return 1;             /* Try again... */

}

/*

** sqlthread open

**

**     Open a database handle and return the string representation of

**     the pointer value.

*/

static int sqlthread_open(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  int sqlite3TestMakePointerStr(Tcl_Interp *interp, char *zPtr, void *p);

  const char *zFilename;

  sqlite3 *db;

  int rc;

  char zBuf[100];

  extern void Md5_Register(sqlite3*);

  zFilename = Tcl_GetString(objv[2]);

  rc = sqlite3_open(zFilename, &db);

  Md5_Register(db);

  sqlite3_busy_handler(db, xBusy, 0);

  if( sqlite3TestMakePointerStr(interp, zBuf, db) ) return TCL_ERROR;

  Tcl_AppendResult(interp, zBuf, 0);

  return TCL_OK;

}

/*

** sqlthread open

**

**     Return the current thread-id (Tcl_GetCurrentThread()) cast to

**     an integer.

*/

static int sqlthread_id(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  Tcl_ThreadId id = Tcl_GetCurrentThread();

  Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id));

  return TCL_OK;

}

/*

** Dispatch routine for the sub-commands of [sqlthread].

*/

static int sqlthread_proc(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  struct SubCommand {

    char *zName;

    Tcl_ObjCmdProc *xProc;

    int nArg;

    char *zUsage;

  } aSub[] = {

    {"parent", sqlthread_parent, 1, "SCRIPT"},

    {"spawn",  sqlthread_spawn,  2, "VARNAME SCRIPT"},

    {"open",   sqlthread_open,   1, "DBNAME"},

    {"id",     sqlthread_id,     0, ""},

    {0, 0, 0}

  };

  struct SubCommand *pSub;

  int rc;

  int iIndex;

  if( objc<2 ){

    Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND");

    return TCL_ERROR;

  }

  rc = Tcl_GetIndexFromObjStruct(

      interp, objv[1], aSub, sizeof(aSub[0]), "sub-command", 0, &iIndex

  );

  if( rc!=TCL_OK ) return rc;

  pSub = &aSub[iIndex];

  if( objc!=(pSub->nArg+2) ){

    Tcl_WrongNumArgs(interp, 2, objv, pSub->zUsage);

    return TCL_ERROR;

  }

  return pSub->xProc(clientData, interp, objc, objv);

}

/*

** The [clock_seconds] command. This is more or less the same as the

** regular tcl [clock seconds], except that it is available in testfixture

** when linked against both Tcl 8.4 and 8.5. Because [clock seconds] is

** implemented as a script in Tcl 8.5, it is not usually available to

** testfixture.

*/ 

static int clock_seconds_proc(

  ClientData clientData,

  Tcl_Interp *interp,

  int objc,

  Tcl_Obj *CONST objv[]

){

  Tcl_Time now;

  Tcl_GetTime(&now);

  Tcl_SetObjResult(interp, Tcl_NewIntObj(now.sec));

  return TCL_OK;

}

/*

** Register commands with the TCL interpreter.

*/

int SqlitetestThread_Init(Tcl_Interp *interp){

  Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, 0, 0);

  Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);

  return TCL_OK;

}

#else

int SqlitetestThread_Init(Tcl_Interp *interp){

  return TCL_OK;

}

#endif