/ Check-in [9b7bab7f]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Modify test_thread.c to use tcl apis for creating threads. (CVS 4415)
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 9b7bab7fc28201b62159e959651acb980095ad06
User & Date: danielk1977 2007-09-07 18:40:38
Context
2007-09-10
06:12
Fix an undeclared identifier in an IOTRACE (debugging) block. (CVS 4416) check-in: 48e59c74 user: danielk1977 tags: trunk
2007-09-07
18:40
Modify test_thread.c to use tcl apis for creating threads. (CVS 4415) check-in: 9b7bab7f user: danielk1977 tags: trunk
14:32
Fix a segfault that could occur while attempting to add new pages to the freelist in a corrupt database. (CVS 4414) check-in: c8e85fff user: drh tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to src/test_thread.c.

10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37







38
39


40
41
42
43
44

45
46
47

48
49






50









51
52




















53
54
55
56
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74
75

76
77
78

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126




127
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203
204
205




206



207
208
209
210
211
212
213
214
215
216
217
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
**
*************************************************************************
**
** 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.1 2007/09/07 11:29:25 danielk1977 Exp $
*/

#include "sqliteInt.h"

#if defined(OS_UNIX) && SQLITE_THREADSAFE

#include <tcl.h>
#include <pthread.h>
#include <errno.h>
#include <unistd.h>

/*
** One of these is allocated for each thread created by [sqlthread spawn].
*/
typedef struct SqlThread SqlThread;
struct SqlThread {
  int fd;            /* The pipe to send commands to the parent */

  char *zScript;     /* The script to execute. */
  char *zVarname;    /* Varname in parent script */
};








typedef struct SqlParent SqlParent;
struct SqlParent {


  Tcl_Interp *interp;
  int fd;
};

static Tcl_ObjCmdProc sqlthread_proc;


static void *tclScriptThread(void *pSqlThread){
  Tcl_Interp *interp;

  Tcl_Obj *pRes;
  Tcl_Obj *pList;
















  char *zMsg;
  int nMsg;




















  int rc;

  SqlThread *p = (SqlThread *)pSqlThread;

  interp = Tcl_CreateInterp();
  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);


  if( rc==TCL_OK ){
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
  }else{
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));
  }
  Tcl_ListObjAppendElement(interp, pList, pRes);

  zMsg = Tcl_GetStringFromObj(pList, &nMsg); 
  write(p->fd, zMsg, nMsg+1);

  close(p->fd);
  sqlite3_free(p);
  Tcl_DecrRefCount(pList);

  Tcl_DeleteInterp(interp);

  return 0;
}

void pipe_callback(ClientData clientData, int flags){
  SqlParent *p = (SqlParent *)clientData;
  char zBuf[1024];
  int nChar;

  nChar = read(p->fd, zBuf, 1023);
  if( nChar<=0 ){
    /* Other end has been closed */
    Tcl_DeleteFileHandler(p->fd);
    sqlite3_free(p);
  }else{
    zBuf[1023] = '\0';
    if( TCL_OK!=Tcl_Eval(p->interp, zBuf) ){
      Tcl_BackgroundError(p->interp);
    }
  }
}

/*
** sqlthread spawn VARNAME SCRIPT
**
**     Spawn a new thread with it's own Tcl interpreter and run the
**     specified SCRIPT(s) in it. The thread terminates after running
................................................................................
*/
static int sqlthread_spawn(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *CONST objv[]
){
  pthread_t x;
  SqlThread *pNew;
  SqlParent *pParent;
  int fds[2];
  int rc;

  int nVarname; char *zVarname;
  int nScript; char *zScript;





  assert(objc==4);

  zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);
  zScript = Tcl_GetStringFromObj(objv[3], &nScript);
  pNew = (SqlThread *)sqlite3_malloc(sizeof(SqlThread)+nVarname+nScript+2);
  if( pNew==0 ){
    Tcl_AppendResult(interp, "Malloc failure", 0);
    return TCL_ERROR;
  }

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

  pParent = (SqlParent *)sqlite3_malloc(sizeof(SqlParent));
  if( pParent==0 ){
    Tcl_AppendResult(interp, "Malloc failure", 0);
    sqlite3_free(pNew);
    return TCL_ERROR;
  }

  rc = pipe(fds);
  if( rc!=0 ){
    Tcl_AppendResult(interp, "Error in pipe(): ", strerror(errno), 0);
    sqlite3_free(pNew);
    sqlite3_free(pParent);
    return TCL_ERROR;
  }

  pParent->fd = fds[0];

  pParent->interp = interp;
  Tcl_CreateFileHandler(
      fds[0], TCL_READABLE|TCL_EXCEPTION, pipe_callback, (void *)pParent
  );

  pNew->fd = fds[1];
  rc = pthread_create(&x, 0, tclScriptThread, (void *)pNew);
  if( rc!=0 ){
    Tcl_AppendResult(interp, "Error in pthread_create(): ", strerror(errno), 0);
    Tcl_DeleteFileHandler(fds[0]);
    sqlite3_free(pNew);
    sqlite3_free(pParent);
    close(fds[0]);
    close(fds[1]);
    return TCL_ERROR;
  }

  return TCL_OK;
}

/*
................................................................................
**     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.
*/
#if 0
static int sqlthread_parent(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *CONST objv[]
){

  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);




  write(p->fd, zMsg, nMsg+1);




  return TCL_OK;
}
#endif

/*
** Dispatch routine for the sub-commands of [sqlthread].
*/
static int sqlthread_proc(
  ClientData clientData,
  Tcl_Interp *interp,
................................................................................
){
  struct SubCommand {
    char *zName;
    Tcl_ObjCmdProc *xProc;
    int nArg;
    char *zUsage;
  } aSub[] = {
#if 0
    {"parent", sqlthread_parent, 1, "SCRIPT"},
#endif
    {"spawn",  sqlthread_spawn,  2, "VARNAME SCRIPT"},
    {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;







|



>
|


<








|
>
|
|


>
>
>
>
>
>
>
|
|
>
>
|
<



>

<
<
>
|
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>









|
<
>
|
<

>

<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|

<
<





>
>
>
>




<
<
<
<
|
>




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
<
<

<
|
|
|
<

<
<
<







 







<






>











>
>
>
>
|
>
>
>



<







 







<

<













|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

51
52
53
54
55


56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

120
121

122
123
124

125


















126
127
128
129
130
131
132
...
137
138
139
140
141
142
143
144
145


146
147
148
149
150
151
152
153
154
155
156
157
158




159
160
161
162
163
164

















165
166



167

168
169
170

171



172
173
174
175
176
177
178
...
182
183
184
185
186
187
188

189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217

218
219
220
221
222
223
224
...
227
228
229
230
231
232
233

234

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
**
*************************************************************************
**
** 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.2 2007/09/07 18:40:38 danielk1977 Exp $
*/

#include "sqliteInt.h"

#if SQLITE_THREADSAFE && defined(TCL_THREADS)

#include <tcl.h>

#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;
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, "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("set", -1));
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
  }else{
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -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 it's own Tcl interpreter and run the
**     specified SCRIPT(s) in it. The thread terminates after running
................................................................................
*/
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);

    sqlite3_free(pNew);



    return TCL_ERROR;
  }

  return TCL_OK;
}

/*
................................................................................
**     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;
}


/*
** Dispatch routine for the sub-commands of [sqlthread].
*/
static int sqlthread_proc(
  ClientData clientData,
  Tcl_Interp *interp,
................................................................................
){
  struct SubCommand {
    char *zName;
    Tcl_ObjCmdProc *xProc;
    int nArg;
    char *zUsage;
  } aSub[] = {

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

    {"spawn",  sqlthread_spawn,  2, "VARNAME SCRIPT"},
    {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;

Changes to test/thread001.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18



19
20
21
22
23
24
25
..
59
60
61
62
63
64
65







66
67
68

69
70
71
72
73
74


75
76
77
78
79
80
81
#
#    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.
#
#***********************************************************************
#
# $Id: thread001.test,v 1.1 2007/09/07 11:29:25 danielk1977 Exp $

set testdir [file dirname $argv0]
source $testdir/tester.tcl

if {[info commands sqlthread] eq ""} {
  puts "Skipping thread-safety tests - not running a threadsafe unix build"



  finish_test
  return
}

# Set up a database and a schema. The database contains a single
# table with two columns. The first column ("a") is an INTEGER PRIMARY 
# KEY. The second contains the md5sum of all rows in the table with
................................................................................
    }
    set rc [sqlite3_finalize $::STMT]
    if {$rc ne "SQLITE_OK"} {
      error [sqlite3_errmsg $::DB]
    }
    set res
  }








  for {set i 0} {$i < 100} {incr i} {
    # Test that the invariant is true.

    set val [execsql {
      SELECT 
        (SELECT md5sum(a, b) FROM ab WHERE a < (SELECT max(a) FROM ab)) ==
        (SELECT b FROM ab WHERE a = (SELECT max(a) FROM ab))
    }]
    if {$val ne "1"} {error "Invariant test failed"}



    # Add another row to the database.
    execsql { INSERT INTO ab SELECT NULL, md5sum(a, b) FROM ab }
  }

  list OK
} [sqlite3_connection_pointer db]]







|





|
>
>
>







 







>
>
>
>
>
>
>



>
|
|
|
|
<
<
>
>







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83


84
85
86
87
88
89
90
91
92
#
#    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.
#
#***********************************************************************
#
# $Id: thread001.test,v 1.2 2007/09/07 18:40:38 danielk1977 Exp $

set testdir [file dirname $argv0]
source $testdir/tester.tcl

if {[info commands sqlthread] eq ""} {
  puts -nonewline "Skipping thread-safety tests - "
  puts            " not running a threadsafe sqlite/tcl build"
  puts -nonewline "Both SQLITE_THREADSAFE and TCL_THREADS must be defined when"
  puts            " building testfixture"
  finish_test
  return
}

# Set up a database and a schema. The database contains a single
# table with two columns. The first column ("a") is an INTEGER PRIMARY 
# KEY. The second contains the md5sum of all rows in the table with
................................................................................
    }
    set rc [sqlite3_finalize $::STMT]
    if {$rc ne "SQLITE_OK"} {
      error [sqlite3_errmsg $::DB]
    }
    set res
  }

  proc do_test {name script result} {
    set res [eval $script]
    if {$res ne $result} {
      error "$name failed: expected \"$result\" got \"$res\""
    }
  }

  for {set i 0} {$i < 100} {incr i} {
    # Test that the invariant is true.
    do_test t1 {
      execsql {
        SELECT 
          (SELECT md5sum(a, b) FROM ab WHERE a < (SELECT max(a) FROM ab)) ==
          (SELECT b FROM ab WHERE a = (SELECT max(a) FROM ab))


      }
    } {1}

    # Add another row to the database.
    execsql { INSERT INTO ab SELECT NULL, md5sum(a, b) FROM ab }
  }

  list OK
} [sqlite3_connection_pointer db]]