Tcl package Thread source code

Check-in [e59ef6f0be]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Don't use STRLEN_TYPE et al any more, it's superseded by TIP #494. Also eliminate a ton of unnecessary type casts
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | novem
Files: files | file ages | folders
SHA3-256: e59ef6f0be475d3d16f65d1d2f2a5b1679f998450d8614f49b42961cc5343278
User & Date: jan.nijtmans 2018-11-24 09:06:23
Context
2018-11-24
09:08
Merge trunk check-in: 25c47ce840 user: jan.nijtmans tags: novem
09:06
Don't use STRLEN_TYPE et al any more, it's superseded by TIP #494. Also eliminate a ton of unnecessary type casts check-in: e59ef6f0be user: jan.nijtmans tags: novem
2018-10-16
21:39
Merge trunk check-in: 5952623bc7 user: jan.nijtmans tags: novem
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/psGdbm.c.

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
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
...
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
...
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
...
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *      Opaque handle of the opened dbm storage.
 *
 * Side effects:
 *      The gdbm file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static ClientData
ps_gdbm_open(
    const char *path)
{
    GDBM_FILE dbf;
    char *ext;
    Tcl_DString toext;

    Tcl_DStringInit(&toext);
    ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
    dbf = gdbm_open(ext, 512, GDBM_WRCREAT|GDBM_SYNC|GDBM_NOLOCK, 0666, NULL);
    Tcl_DStringFree(&toext);

    return (ClientData)dbf;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ps_gdbm_close --
 *
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_close(
    ClientData handle)
{
    gdbm_close((GDBM_FILE)handle);

    return 0;
}
 
/*
................................................................................
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_get(
     ClientData handle,
     const char   *key,
     char **dataptrptr,
     size_t    *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

................................................................................
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_first(
    ClientData  handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

................................................................................
 *
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_gdbm_next(
    ClientData  handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey, dnext;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_put(
    ClientData handle,
    const char   *key,
    char     *dataptr,
    size_t        len)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;
    int ret;
................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_delete(
    ClientData handle,
    const char   *key)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum dkey;
    int ret;

    dkey.dptr  = (char*)key;
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_gdbm_free(
    ClientData handle,
    void        *data)
{
    (void)handle;
    free(data);
}
 
/*
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_gdbm_geterr(
    ClientData handle)
{
   /*
    * The problem with gdbm interface is that it uses the global
    * gdbm_errno variable which is not per-thread nor mutex
    * protected. This variable is used to reference array of gdbm
    * error text strings. It is very dangeours to use this in the
    * MT-program without proper locking. For this kind of app






|












|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







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
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
...
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
...
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
...
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *      Opaque handle of the opened dbm storage.
 *
 * Side effects:
 *      The gdbm file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static void *
ps_gdbm_open(
    const char *path)
{
    GDBM_FILE dbf;
    char *ext;
    Tcl_DString toext;

    Tcl_DStringInit(&toext);
    ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
    dbf = gdbm_open(ext, 512, GDBM_WRCREAT|GDBM_SYNC|GDBM_NOLOCK, 0666, NULL);
    Tcl_DStringFree(&toext);

    return dbf;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ps_gdbm_close --
 *
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_close(
    void *handle)
{
    gdbm_close((GDBM_FILE)handle);

    return 0;
}
 
/*
................................................................................
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_get(
     void *handle,
     const char   *key,
     char **dataptrptr,
     size_t    *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

................................................................................
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_first(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

................................................................................
 *
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_gdbm_next(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey, dnext;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_put(
    void *handle,
    const char   *key,
    char     *dataptr,
    size_t        len)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;
    int ret;
................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_delete(
    void *handle,
    const char   *key)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum dkey;
    int ret;

    dkey.dptr  = (char*)key;
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_gdbm_free(
    void *handle,
    void        *data)
{
    (void)handle;
    free(data);
}
 
/*
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_gdbm_geterr(
    void *handle)
{
   /*
    * The problem with gdbm interface is that it uses the global
    * gdbm_errno variable which is not per-thread nor mutex
    * protected. This variable is used to reference array of gdbm
    * error text strings. It is very dangeours to use this in the
    * MT-program without proper locking. For this kind of app

Changes to generic/psLmdb.c.

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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
...
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
...
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
 *      Opaque handle for LmdbCtx.
 *
 * Side effects:
 *      The lmdb file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static ClientData
ps_lmdb_open(
    const char *path)
{
    LmdbCtx ctx;

    char *ext;
    Tcl_DString toext;

    ctx = ckalloc(sizeof(*ctx));
    if (ctx == NULL)
    {
        return NULL;
    }

    ctx->env = NULL;
    ctx->txn = NULL;
    ctx->cur = NULL;
    ctx->dbi = 0;

    ctx->err = mdb_env_create(&ctx->env);
    if (ctx->err)
    {
        ckfree(ctx);
        return NULL;
    }

    Tcl_DStringInit(&toext);
    ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
    ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666);
    Tcl_DStringFree(&toext);

    if (ctx->err)
    {
        ckfree(ctx);
        return NULL;
    }

    return (ClientData)ctx;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ps_lmdb_close --
 *
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_close(
    ClientData handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    if (ctx->cur)
    {
        mdb_cursor_close(ctx->cur);
    }
    if (ctx->txn)
    {
        LmdbTxnAbort(ctx);
    }

    mdb_env_close(ctx->env);
    ckfree(ctx);

    return 0;
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_get(
     ClientData  handle,
     const char *keyptr,
     char  **dataptrptr,
     size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_first(
    ClientData  handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_lmdb_next(
    ClientData  handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_put(
    ClientData  handle,
    const char *keyptr,
    char      *dataptr,
    size_t         len)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_delete(
    ClientData  handle,
    const char *keyptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key;

    LmdbTxnGet(ctx, LmdbWrite);
    if (ctx->err)
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_lmdb_free(
    ClientData handle,
    void        *data)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    (void)data;

    if (ctx->cur == NULL)
    {
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_lmdb_geterr(
    ClientData handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    return mdb_strerror(ctx->err);
}

#endif  /* HAVE_LMDB */







|








|













|










|



|







 







|












|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
...
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
...
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
 *      Opaque handle for LmdbCtx.
 *
 * Side effects:
 *      The lmdb file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static void *
ps_lmdb_open(
    const char *path)
{
    LmdbCtx ctx;

    char *ext;
    Tcl_DString toext;

    ctx = Tcl_Alloc(sizeof(*ctx));
    if (ctx == NULL)
    {
        return NULL;
    }

    ctx->env = NULL;
    ctx->txn = NULL;
    ctx->cur = NULL;
    ctx->dbi = 0;

    ctx->err = mdb_env_create(&ctx->env);
    if (ctx->err)
    {
        Tcl_Free(ctx);
        return NULL;
    }

    Tcl_DStringInit(&toext);
    ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
    ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666);
    Tcl_DStringFree(&toext);

    if (ctx->err)
    {
    	Tcl_Free(ctx);
        return NULL;
    }

    return ctx;
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * ps_lmdb_close --
 *
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_close(
    void *handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    if (ctx->cur)
    {
        mdb_cursor_close(ctx->cur);
    }
    if (ctx->txn)
    {
        LmdbTxnAbort(ctx);
    }

    mdb_env_close(ctx->env);
    Tcl_Free(ctx);

    return 0;
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_get(
     void *handle,
     const char *keyptr,
     char  **dataptrptr,
     size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_first(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_lmdb_next(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_put(
    void *handle,
    const char *keyptr,
    char      *dataptr,
    size_t         len)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

................................................................................
 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_delete(
    void *handle,
    const char *keyptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key;

    LmdbTxnGet(ctx, LmdbWrite);
    if (ctx->err)
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_lmdb_free(
    void *handle,
    void        *data)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    (void)data;

    if (ctx->cur == NULL)
    {
................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_lmdb_geterr(
    void *handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    return mdb_strerror(ctx->err);
}

#endif  /* HAVE_LMDB */

Changes to generic/tclThreadInt.h.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
#define _TCL_THREAD_INT_H_

#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */
#include <stdarg.h> /* For va_list */

#ifdef TCL_STRLEN
# define STRLEN_TYPE size_t
#else
# define TCL_STRLEN (-1)
# define STRLEN_TYPE int
#endif

/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).
 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus
................................................................................
        (a)->nextPtr->prevPtr = (a)->prevPtr

/*
 * Utility macros
 */

#define TCL_CMD(a,b,c) \
  if (Tcl_CreateObjCommand((a),(b),(c),(ClientData)NULL, NULL) == NULL) \
    return TCL_ERROR

#define OPT_CMP(a,b) \
  ((a) && (b) && (*(a)==*(b)) && (*(a+1)==*(b+1)) && (!strcmp((a),(b))))

#ifndef TCL_TSD_INIT
#define TCL_TSD_INIT(keyPtr) \






<
<
<
<
<
<
<







 







|







16
17
18
19
20
21
22







23
24
25
26
27
28
29
..
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#define _TCL_THREAD_INT_H_

#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */
#include <stdarg.h> /* For va_list */








/*
 * Used to tag functions that are only to be visible within the module being
 * built and not outside it (where this is supported by the linker).
 */

#ifndef MODULE_SCOPE
#   ifdef __cplusplus
................................................................................
        (a)->nextPtr->prevPtr = (a)->prevPtr

/*
 * Utility macros
 */

#define TCL_CMD(a,b,c) \
  if (Tcl_CreateObjCommand((a),(b),(c),NULL, NULL) == NULL) \
    return TCL_ERROR

#define OPT_CMP(a,b) \
  ((a) && (b) && (*(a)==*(b)) && (*(a+1)==*(b+1)) && (!strcmp((a),(b))))

#ifndef TCL_TSD_INIT
#define TCL_TSD_INIT(keyPtr) \

Changes to generic/tclXkeylist.c.

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
276
277
278
279
280
281
282
283
284
285






286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
...
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
...
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
...
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
...
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
...
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
...
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
...
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
...
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
...
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
....
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
....
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
....
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
....
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
....
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
                            panic("TclX assertion failure: %s:%d \"%s\"\n",\
                            __FILE__, __LINE__, "expr"))
#else
# define TclX_Assert(expr)
#endif

/*
 * Macro that behaves like strdup, only uses ckalloc.  Also macro that does the
 * same with a string that might contain zero bytes,
 */

#define ckstrdup(sourceStr) \
  (strcpy (ckalloc (strlen (sourceStr) + 1), sourceStr))

#define ckbinstrdup(sourceStr, length) \
  ((char *) memcpy (ckalloc (length + 1), sourceStr, length + 1))

/*
 * Used to return argument messages by most commands.
 */
static const char *tclXWrongArgs = "wrong # args: ";

static const Tcl_ObjType *listType;
................................................................................
SetKeyedListFromAny(Tcl_Interp *interp,
                                 Tcl_Obj    *objPtr);

static void
UpdateStringOfKeyedList(Tcl_Obj *keylPtr);

static int
Tcl_KeylgetObjCmd(ClientData   clientData,
                               Tcl_Interp  *interp,
                               STRLEN_TYPE  objc,






                               Tcl_Obj     *const objv[]);

static int
Tcl_KeylsetObjCmd(ClientData   clientData,
                               Tcl_Interp  *interp,
                               STRLEN_TYPE  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeyldelObjCmd(ClientData   clientData,
                               Tcl_Interp  *interp,
                               STRLEN_TYPE  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeylkeysObjCmd(ClientData   clientData,
                                Tcl_Interp  *interp,
                                STRLEN_TYPE  objc,
                                Tcl_Obj     *const objv[]);

/*
 * Type definition.
 */
const Tcl_ObjType keyedListType = {
    "keyedList",              /* name */
................................................................................
 *-----------------------------------------------------------------------------
 */
static keylIntObj_t *
AllocKeyedListIntRep ()
{
    keylIntObj_t *keylIntPtr;

    keylIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));

    keylIntPtr->arraySize = 0;
    keylIntPtr->numEntries = 0;
    keylIntPtr->entries = NULL;

    return keylIntPtr;
}
................................................................................
static void
FreeKeyedListData (keylIntPtr)
    keylIntObj_t *keylIntPtr;
{
    int idx;

    for (idx = 0; idx < keylIntPtr->numEntries ; idx++) {
        ckfree (keylIntPtr->entries [idx].key);
        Tcl_DecrRefCount (keylIntPtr->entries [idx].valuePtr);
    }
    if (keylIntPtr->entries != NULL)
        ckfree ((char *) keylIntPtr->entries);
    ckfree ((char *) keylIntPtr);
}
 
/*-----------------------------------------------------------------------------
 * EnsureKeyedListSpace --
 *   Ensure there is enough room in a keyed list array for a certain number
 * of entries, expanding if necessary.
 *
................................................................................
{
    KEYL_REP_ASSERT (keylIntPtr);

    if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) {
        int newSize = keylIntPtr->arraySize + newNumEntries +
            KEYEDLIST_ARRAY_INCR_SIZE;
        if (keylIntPtr->entries == NULL) {
            keylIntPtr->entries = (keylEntry_t *)
                ckalloc (newSize * sizeof (keylEntry_t));
        } else {
            keylIntPtr->entries = (keylEntry_t *)
                ckrealloc ((void *) keylIntPtr->entries,
                           newSize * sizeof (keylEntry_t));
        }
        keylIntPtr->arraySize = newSize;
    }

    KEYL_REP_ASSERT (keylIntPtr);
}
 
................................................................................
static void
DeleteKeyedListEntry (keylIntPtr, entryIdx)
    keylIntObj_t *keylIntPtr;
    int           entryIdx;
{
    int idx;

    ckfree (keylIntPtr->entries [entryIdx].key);
    Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr);

    for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++)
        keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1];
    keylIntPtr->numEntries--;

    KEYL_REP_ASSERT (keylIntPtr);
................................................................................
 */
static int
ObjToKeyedListEntry (interp, objPtr, entryPtr)
    Tcl_Interp  *interp;
    Tcl_Obj     *objPtr;
    keylEntry_t *entryPtr;
{
    STRLEN_TYPE objc;
    Tcl_Obj **objv;
    const char *key;

    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
        Tcl_ResetResult (interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult (interp),
                                "keyed list entry not a valid list, ",
................................................................................
    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries = (keylEntry_t *)
        ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr;
        Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr);
    }
................................................................................
    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries = (keylEntry_t *)
        ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr =
            Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr);
        Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr);
................................................................................
static int
SetKeyedListFromAny (interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj    *objPtr;
{
    keylIntObj_t *keylIntPtr;
    int idx;
    STRLEN_TYPE objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK)
        return TCL_ERROR;

    keylIntPtr = AllocKeyedListIntRep ();

................................................................................
        keylPtr->internalRep.twoPtrValue.ptr1;

    /*
     * Conversion to strings is done via list objects to support binary data.
     */
    if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) {
        listObjv =
            (Tcl_Obj **) ckalloc (keylIntPtr->numEntries * sizeof (Tcl_Obj *));
    } else {
        listObjv = staticListObjv;
    }

    /*
     * Convert each keyed list entry to a two element list object.  No
     * need to incr/decr ref counts, the list objects will take care of that.
................................................................................
    tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv);
    listStr = Tcl_GetString(tmpListObj);
    keylPtr->bytes = ckbinstrdup(listStr, tmpListObj->length);
    keylPtr->length = tmpListObj->length;

    Tcl_DecrRefCount (tmpListObj);
    if (listObjv != staticListObjv)
        ckfree ((void*) listObjv);
}
 
/*-----------------------------------------------------------------------------
 * TclX_NewKeyedListObj --
 *   Create and initialize a new keyed list object.
 *
 * Returns:
................................................................................
     */
    if (nextSubKey == NULL) {
        if (findIdx < 0) {
            EnsureKeyedListSpace (keylIntPtr, 1);
            findIdx = keylIntPtr->numEntries;
            keylIntPtr->numEntries++;
        } else {
            ckfree (keylIntPtr->entries [findIdx].key);
            Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr);
        }
        keylIntPtr->entries [findIdx].key =
            (char *) ckalloc (keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = valuePtr;
        Tcl_IncrRefCount (valuePtr);
        Tcl_InvalidateStringRep (keylPtr);

        KEYL_REP_ASSERT (keylIntPtr);
................................................................................
                               nextSubKey, valuePtr) != TCL_OK) {
            Tcl_DecrRefCount (newKeylPtr);
            return TCL_ERROR;
        }
        EnsureKeyedListSpace (keylIntPtr, 1);
        findIdx = keylIntPtr->numEntries++;
        keylIntPtr->entries [findIdx].key =
            (char *) ckalloc (keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = newKeylPtr;
        Tcl_IncrRefCount (newKeylPtr);
        Tcl_InvalidateStringRep (keylPtr);

        KEYL_REP_ASSERT (keylIntPtr);
................................................................................
 * Tcl_KeylgetObjCmd --
 *     Implements the TCL keylget command:
 *         keylget listvar ?key? ?retvar | {}?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylgetObjCmd (clientData, interp, objc, objv)
    ClientData   clientData;
    Tcl_Interp  *interp;
    STRLEN_TYPE  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylPtr, *valuePtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 4)) {
................................................................................
 * Tcl_KeylsetObjCmd --
 *     Implements the TCL keylset command:
 *         keylset listvar key value ?key value...?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylsetObjCmd (clientData, interp, objc, objv)
    ClientData   clientData;
    Tcl_Interp  *interp;
    STRLEN_TYPE  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylVarPtr, *newVarObj;
    const char *key;
    int idx;

    if ((objc < 4) || ((objc % 2) != 0)) {
................................................................................
 * Tcl_KeyldelObjCmd --
 *     Implements the TCL keyldel command:
 *         keyldel listvar key ?key ...?
 *----------------------------------------------------------------------------
 */
static int
Tcl_KeyldelObjCmd (clientData, interp, objc, objv)
    ClientData   clientData;
    Tcl_Interp  *interp;
    STRLEN_TYPE  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylVarPtr, *keylPtr;
    const char *key;
    int idx, status;

    if (objc < 3) {
................................................................................
 * Tcl_KeylkeysObjCmd --
 *     Implements the TCL keylkeys command:
 *         keylkeys listvar ?key?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylkeysObjCmd (clientData, interp, objc, objv)
    ClientData   clientData;
    Tcl_Interp  *interp;
    STRLEN_TYPE  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylPtr, *listObjPtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 3)) {
................................................................................
    listType = listobj->typePtr;
    Tcl_DecrRefCount(listobj);

    if (0) {
    Tcl_CreateObjCommand (interp,
                          "keylget",
                          Tcl_KeylgetObjCmd,
                          (ClientData) NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylset",
                          Tcl_KeylsetObjCmd,
                          (ClientData) NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keyldel",
                          Tcl_KeyldelObjCmd,
                          (ClientData) NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylkeys",
                          Tcl_KeylkeysObjCmd,
                          (ClientData) NULL,
                          (Tcl_CmdDeleteProc*) NULL);
    }
}








|




|


|







 







|

|
>
>
>
>
>
>



|

|



<
<
<
<
<
<
|

|







 







|







 







|
|


|
|







 







|
|

|
|
|







 







|







 







|







 







|


|
|







 







|


|
|







 







|







 







|







 







|







 







|



|







 







|







 







|

|







 







|

|







 







|

|







 







|

|







 







|





|





|





|





45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300






301
302
303
304
305
306
307
308
309
310
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
...
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
...
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
...
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
...
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
...
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
...
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
...
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
...
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
...
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
....
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
....
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
....
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
....
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
....
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
                            panic("TclX assertion failure: %s:%d \"%s\"\n",\
                            __FILE__, __LINE__, "expr"))
#else
# define TclX_Assert(expr)
#endif

/*
 * Macro that behaves like strdup, only uses Tcl_Alloc.  Also macro that does the
 * same with a string that might contain zero bytes,
 */

#define ckstrdup(sourceStr) \
  strcpy (Tcl_Alloc(strlen (sourceStr) + 1), sourceStr)

#define ckbinstrdup(sourceStr, length) \
  memcpy(Tcl_Alloc(length + 1), sourceStr, length + 1)

/*
 * Used to return argument messages by most commands.
 */
static const char *tclXWrongArgs = "wrong # args: ";

static const Tcl_ObjType *listType;
................................................................................
SetKeyedListFromAny(Tcl_Interp *interp,
                                 Tcl_Obj    *objPtr);

static void
UpdateStringOfKeyedList(Tcl_Obj *keylPtr);

static int
Tcl_KeylgetObjCmd(void *       clientData,
                               Tcl_Interp  *interp,
                               int  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeylsetObjCmd(void *       clientData,
                               Tcl_Interp  *interp,
                               int  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeyldelObjCmd(void *       clientData,
                               Tcl_Interp  *interp,
                               int  objc,
                               Tcl_Obj     *const objv[]);

static int






Tcl_KeylkeysObjCmd(void *       clientData,
                                Tcl_Interp  *interp,
                                int  objc,
                                Tcl_Obj     *const objv[]);

/*
 * Type definition.
 */
const Tcl_ObjType keyedListType = {
    "keyedList",              /* name */
................................................................................
 *-----------------------------------------------------------------------------
 */
static keylIntObj_t *
AllocKeyedListIntRep ()
{
    keylIntObj_t *keylIntPtr;

    keylIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));

    keylIntPtr->arraySize = 0;
    keylIntPtr->numEntries = 0;
    keylIntPtr->entries = NULL;

    return keylIntPtr;
}
................................................................................
static void
FreeKeyedListData (keylIntPtr)
    keylIntObj_t *keylIntPtr;
{
    int idx;

    for (idx = 0; idx < keylIntPtr->numEntries ; idx++) {
        Tcl_Free(keylIntPtr->entries[idx].key);
        Tcl_DecrRefCount (keylIntPtr->entries[idx].valuePtr);
    }
    if (keylIntPtr->entries != NULL)
        Tcl_Free(keylIntPtr->entries);
    Tcl_Free(keylIntPtr);
}
 
/*-----------------------------------------------------------------------------
 * EnsureKeyedListSpace --
 *   Ensure there is enough room in a keyed list array for a certain number
 * of entries, expanding if necessary.
 *
................................................................................
{
    KEYL_REP_ASSERT (keylIntPtr);

    if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) {
        int newSize = keylIntPtr->arraySize + newNumEntries +
            KEYEDLIST_ARRAY_INCR_SIZE;
        if (keylIntPtr->entries == NULL) {
            keylIntPtr->entries =
                Tcl_Alloc(newSize * sizeof(keylEntry_t));
        } else {
            keylIntPtr->entries =
                Tcl_Realloc(keylIntPtr->entries,
                           newSize * sizeof(keylEntry_t));
        }
        keylIntPtr->arraySize = newSize;
    }

    KEYL_REP_ASSERT (keylIntPtr);
}
 
................................................................................
static void
DeleteKeyedListEntry (keylIntPtr, entryIdx)
    keylIntObj_t *keylIntPtr;
    int           entryIdx;
{
    int idx;

    Tcl_Free(keylIntPtr->entries [entryIdx].key);
    Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr);

    for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++)
        keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1];
    keylIntPtr->numEntries--;

    KEYL_REP_ASSERT (keylIntPtr);
................................................................................
 */
static int
ObjToKeyedListEntry (interp, objPtr, entryPtr)
    Tcl_Interp  *interp;
    Tcl_Obj     *objPtr;
    keylEntry_t *entryPtr;
{
    int objc;
    Tcl_Obj **objv;
    const char *key;

    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
        Tcl_ResetResult (interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult (interp),
                                "keyed list entry not a valid list, ",
................................................................................
    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries =
        Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr;
        Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr);
    }
................................................................................
    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries =
        Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr =
            Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr);
        Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr);
................................................................................
static int
SetKeyedListFromAny (interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj    *objPtr;
{
    keylIntObj_t *keylIntPtr;
    int idx;
    int objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK)
        return TCL_ERROR;

    keylIntPtr = AllocKeyedListIntRep ();

................................................................................
        keylPtr->internalRep.twoPtrValue.ptr1;

    /*
     * Conversion to strings is done via list objects to support binary data.
     */
    if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) {
        listObjv =
            Tcl_Alloc(keylIntPtr->numEntries * sizeof(Tcl_Obj *));
    } else {
        listObjv = staticListObjv;
    }

    /*
     * Convert each keyed list entry to a two element list object.  No
     * need to incr/decr ref counts, the list objects will take care of that.
................................................................................
    tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv);
    listStr = Tcl_GetString(tmpListObj);
    keylPtr->bytes = ckbinstrdup(listStr, tmpListObj->length);
    keylPtr->length = tmpListObj->length;

    Tcl_DecrRefCount (tmpListObj);
    if (listObjv != staticListObjv)
        Tcl_Free(listObjv);
}
 
/*-----------------------------------------------------------------------------
 * TclX_NewKeyedListObj --
 *   Create and initialize a new keyed list object.
 *
 * Returns:
................................................................................
     */
    if (nextSubKey == NULL) {
        if (findIdx < 0) {
            EnsureKeyedListSpace (keylIntPtr, 1);
            findIdx = keylIntPtr->numEntries;
            keylIntPtr->numEntries++;
        } else {
            Tcl_Free(keylIntPtr->entries [findIdx].key);
            Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr);
        }
        keylIntPtr->entries [findIdx].key =
            Tcl_Alloc(keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = valuePtr;
        Tcl_IncrRefCount (valuePtr);
        Tcl_InvalidateStringRep (keylPtr);

        KEYL_REP_ASSERT (keylIntPtr);
................................................................................
                               nextSubKey, valuePtr) != TCL_OK) {
            Tcl_DecrRefCount (newKeylPtr);
            return TCL_ERROR;
        }
        EnsureKeyedListSpace (keylIntPtr, 1);
        findIdx = keylIntPtr->numEntries++;
        keylIntPtr->entries [findIdx].key =
            Tcl_Alloc(keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = newKeylPtr;
        Tcl_IncrRefCount (newKeylPtr);
        Tcl_InvalidateStringRep (keylPtr);

        KEYL_REP_ASSERT (keylIntPtr);
................................................................................
 * Tcl_KeylgetObjCmd --
 *     Implements the TCL keylget command:
 *         keylget listvar ?key? ?retvar | {}?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylgetObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylPtr, *valuePtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 4)) {
................................................................................
 * Tcl_KeylsetObjCmd --
 *     Implements the TCL keylset command:
 *         keylset listvar key value ?key value...?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylsetObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylVarPtr, *newVarObj;
    const char *key;
    int idx;

    if ((objc < 4) || ((objc % 2) != 0)) {
................................................................................
 * Tcl_KeyldelObjCmd --
 *     Implements the TCL keyldel command:
 *         keyldel listvar key ?key ...?
 *----------------------------------------------------------------------------
 */
static int
Tcl_KeyldelObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylVarPtr, *keylPtr;
    const char *key;
    int idx, status;

    if (objc < 3) {
................................................................................
 * Tcl_KeylkeysObjCmd --
 *     Implements the TCL keylkeys command:
 *         keylkeys listvar ?key?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylkeysObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{
    Tcl_Obj *keylPtr, *listObjPtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 3)) {
................................................................................
    listType = listobj->typePtr;
    Tcl_DecrRefCount(listobj);

    if (0) {
    Tcl_CreateObjCommand (interp,
                          "keylget",
                          Tcl_KeylgetObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylset",
                          Tcl_KeylsetObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keyldel",
                          Tcl_KeyldelObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylkeys",
                          Tcl_KeylkeysObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);
    }
}


Changes to generic/threadCmd.c.

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
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
...
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
...
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
...
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
...
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
...
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
...
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
...
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
...
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
...
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
...
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
...
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
...
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
....
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
....
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
....
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
....
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
....
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
....
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
....
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
....
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
....
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
....
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
....
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
....
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
....
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
....
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
....
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
....
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
....
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
....
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
....
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
....
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
....
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
....
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
....
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
....
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
....
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
....
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
....
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
....
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
....
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
....
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
....
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
....
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
....
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
....
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
....
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
....
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
....
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
....
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
....
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
....
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
....
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
....
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
....
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
....
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
....
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
typedef struct ThreadCtrl {
    char *script;                         /* Script to execute */
    int flags;                            /* Initial value of the "flags"
                                           * field in ThreadSpecificData */
    Tcl_Condition condWait;               /* Condition variable used to
                                           * sync parent and child threads */
    ClientData cd;                        /* Opaque ptr to pass to thread */
} ThreadCtrl;

/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
................................................................................
    Tcl_Event event;                      /* Must be first */
    struct ThreadSendData *sendData;      /* See below */
    struct ThreadClbkData *clbkData;      /* See below */
    struct ThreadEventResult *resultPtr;  /* To communicate the result back.
                                           * NULL if we don't care about it */
} ThreadEvent;

typedef int  (ThreadSendProc) (Tcl_Interp*, ClientData);
typedef void (ThreadSendFree) (ClientData);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */

/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
................................................................................
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements identical!
 */

typedef struct ThreadSendData {
    ThreadSendProc *execProc;             /* Func to exec in remote thread */
    ClientData clientData;                /* Ptr to pass to send function */
    ThreadSendFree *freeProc;             /* Function to free client data */
     /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
} ThreadSendData;

typedef struct ThreadClbkData {
    ThreadSendProc *execProc;             /* The callback function */
    ClientData clientData;                /* Ptr to pass to clbk function */
    ThreadSendFree *freeProc;             /* Function to free client data */
    /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
    Tcl_ThreadId threadId;                /* Thread where to post callback */
    ThreadEventResult result;             /* Returns result asynchronously */
} ThreadClbkData;

................................................................................
/*
 * Miscellaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread(ClientData clientData);

static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);

static int
ThreadInit(Tcl_Interp *interp);

................................................................................
static int
ThreadList(Tcl_Interp *interp,
                               Tcl_ThreadId **thrIdArray);
static void
ThreadErrorProc(Tcl_Interp *interp);

static void
ThreadFreeProc(ClientData clientData);

static void
ThreadIdleProc(ClientData clientData);

static void
ThreadExitProc(ClientData clientData);

static void
ThreadFreeError(ClientData clientData);

static void
ListRemove(ThreadSpecificData *tsdPtr);

static void
ListRemoveInner(ThreadSpecificData *tsdPtr);

................................................................................
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->interp == (Tcl_Interp*)NULL) {
        memset(tsdPtr, 0, sizeof(ThreadSpecificData));
        tsdPtr->interp = interp;
        ListUpdate(tsdPtr);
        Tcl_CreateThreadExitHandler(ThreadExitProc,
                                    (ClientData)threadEmptyResult);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadCreateObjCmd --
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCreateObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE   objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    STRLEN_TYPE argc, rsrv = 0;
    const char *arg, *script;
    int flags = TCL_THREAD_NOFLAGS;

    Init(interp);

    /*
     * Syntax: thread::create ?-joinable? ?-preserved? ?script?
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadReserveObjCmd --
 *
 *  This procedure is invoked to process the "thread::preserve" and
 *  "thread::release" Tcl commands, depending on the flag passed by
 *  the ClientData argument. See the user documentation for details
 *  on what those command do.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserveObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId = (Tcl_ThreadId)0;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?threadId?");
        return TCL_ERROR;
    }
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReleaseObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int wait = 0;
    Tcl_ThreadId thrId = (Tcl_ThreadId)0;

    Init(interp);

................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadUnwindObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
................................................................................
 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExitObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int status = 666;

    Init(interp);

    if (objc > 2) {
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadIdObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char thrHandle[THREAD_HNDLMAXLEN];

    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_STRLEN));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadNamesObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, length;
    char *result, thrHandle[THREAD_HNDLMAXLEN];
    Tcl_ThreadId *thrIdArray;
    Tcl_DString threadNames;

................................................................................

    length = Tcl_DStringLength(&threadNames);
    result = Tcl_DStringValue(&threadNames);

    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));

    Tcl_DStringFree(&threadNames);
    ckfree((char*)thrIdArray);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
threadSendFree(ClientData ptr)
{
    ckfree((char *)ptr);
}

static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t size;
    int ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;
................................................................................
        const char *varName = Tcl_GetString(var);
        size_t vsize = var->length + 1;

        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_STRLEN));
            return TCL_ERROR;
        }

        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = (ThreadClbkData*)ckalloc(sizeof(ThreadClbkData));
        clbkPtr->execProc   = ThreadClbkSetVar;
        clbkPtr->freeProc   = threadSendFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = (ClientData)memcpy(ckalloc(vsize), varName, vsize);
    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
    sendPtr->interp     = NULL; /* Signal to use thread main interp */
    sendPtr->execProc   = ThreadSendEval;
    sendPtr->freeProc   = threadSendFree;
    sendPtr->clientData = (ClientData)memcpy(ckalloc(size), script, size);

    ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);

    if (var && (flags & THREAD_SEND_WAIT)) {

        /*
         * Leave job's result in passed variable
................................................................................
 *  Script is sent to all known threads except the caller thread.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadBroadcastObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, nthreads;
    size_t size;
    const char *script;
    Tcl_ThreadId *thrIdArray;
    ThreadSendData *sendPtr, job;
................................................................................
     * to the head of the event queue (as out-of-band message).
     */

    for (ii = 0; ii < nthreads; ii++) {
        if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
            continue; /* Do not broadcast self */
        }
        sendPtr  = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
        *sendPtr = job;
        sendPtr->clientData = (ClientData)memcpy(ckalloc(size), script, size);
        ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
    }

    ckfree((char*)thrIdArray);
    Tcl_ResetResult(interp);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *  Enters the event loop.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadWaitObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
................................................................................
 *  Registers an errorproc.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadErrorProcObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t len;
    char *proc;

    Init(interp);

................................................................................
    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
        return TCL_ERROR;
    }
    Tcl_MutexLock(&threadMutex);
    if (objc == 1) {
        if (errorProcString) {
        	Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_STRLEN));
        }
    } else {
        if (errorProcString) {
            ckfree(errorProcString);
        }
        proc = Tcl_GetString(objv[1]);
        len = objv[1]->length;
        if (len == 0) {
            errorThreadId = NULL;
            errorProcString = NULL;
        } else {
            errorThreadId = Tcl_GetCurrentThread();
            errorProcString = ckalloc(1+strlen(proc));
            strcpy(errorProcString, proc);
            Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
            Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}
 
static void
ThreadFreeError(clientData)
    ClientData clientData;
{
    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        return;
    }
    ckfree(errorProcString);
    errorThreadId = NULL;
    errorProcString = NULL;
    Tcl_MutexUnlock(&threadMutex);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadJoinObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadTransferObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    Tcl_ThreadId thrId;
    Tcl_Channel chan;

    Init(interp);
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadDetachObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_Channel chan;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadAttachObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *chanName;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExistsObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    if (objc != 2) {
................................................................................
 *
 * Side effects:
 *  None.
 *----------------------------------------------------------------------
 */
static int
ThreadConfigureObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *option, *value;
    Tcl_ThreadId thrId;         /* Id of the thread to configure */
    int i;                      /* Iterate over arg-value pairs. */
    Tcl_DString ds;             /* DString to hold result of
                                 * calling GetThreadOption. */
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancelObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;
    int ii, flags;
    const char *result;

    if ((objc < 2) || (objc > 4)) {
................................................................................
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSendEval(interp, clientData)
    Tcl_Interp *interp;
    ClientData clientData;
{
    ThreadSendData *sendPtr = (ThreadSendData*)clientData;
    char *script = (char*)sendPtr->clientData;

    return Tcl_EvalEx(interp, script, TCL_STRLEN, TCL_EVAL_GLOBAL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadClbkSetVar --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    ClientData clientData;
{
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    const char *var = (const char *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */

    valObj = Tcl_NewStringObj(resultPtr->result, TCL_STRLEN);
    Tcl_IncrRefCount(valObj);

    if (resultPtr->result != threadEmptyResult) {
        ckfree(resultPtr->result);
    }

    /*
     * Set the result variable
     */

    if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
................................................................................
    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            var = "errorCode";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorCode, TCL_STRLEN), TCL_GLOBAL_ONLY);
            ckfree((char*)resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            var = "errorInfo";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorInfo, TCL_STRLEN), TCL_GLOBAL_ONLY);
            ckfree((char*)resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundException(interp, TCL_ERROR);
    }

cleanup:
    Tcl_DecrRefCount(valObj);
................................................................................

    ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL);
    ctrl.script   = (char *)script;
    ctrl.condWait = NULL;
    ctrl.flags    = 0;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&thrId, NewThread, (ClientData)&ctrl,
            stacksize, flags) != TCL_OK) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_STRLEN));
        return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using
     * the ThreadCtrl argument which is on our stack.
     */
................................................................................
        tsdPtr->refCount++;
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ConditionFinalize(&ctrl.condWait);

    ThreadGetHandle(thrId, thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_STRLEN));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *    A Tcl script is executed in a new thread.
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadCreateType
NewThread(clientData)
    ClientData clientData;
{
    ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK, scriptLen;
    char *evalScript;

    /*
     * Initialize the interpreter. The bad thing here is that we
................................................................................

    /*
     * We need to keep a pointer to the alloc'ed mem of the script
     * we are eval'ing, for the case that we exit during evaluation
     */

    scriptLen = strlen(ctrlPtr->script);
    evalScript = strcpy((char*)ckalloc(scriptLen+1), ctrlPtr->script);
    Tcl_CreateThreadExitHandler(ThreadExitProc,(ClientData)evalScript);

    /*
     * Notify the parent we are alive.
     */

    ctrlPtr->script = NULL;
    Tcl_ConditionNotify(&ctrlPtr->condWait);
................................................................................

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve((ClientData)tsdPtr->interp);
    result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
        ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up. Note: add something like TlistRemove for the transfer list.
................................................................................

#ifdef NS_AOLSERVER
    Ns_TclMarkForDelete(tsdPtr->interp);
    Ns_TclDeAllocateInterp(tsdPtr->interp);
#else
    Tcl_DeleteInterp(tsdPtr->interp);
#endif
    Tcl_Release((ClientData)tsdPtr->interp);

    /*tsdPtr->interp = NULL;*/

    /*
     * Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls
     * ThreadExitHandlers and cleans the notifier as well as other sub-
     * systems that save thread state data.
................................................................................
        Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
        if (errChannel == NULL) {
            /* Fixes the [#634845] bug; credits to
             * Wojciech Kocjan <[email protected]> */
            return;
        }
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_WriteChars(errChannel, "Error from thread ", TCL_STRLEN);
        Tcl_WriteChars(errChannel, buf, TCL_STRLEN);
        Tcl_WriteChars(errChannel, "\n", 1);
        Tcl_WriteChars(errChannel, errorInfo, TCL_STRLEN);
        Tcl_WriteChars(errChannel, "\n", 1);
#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
        sendPtr->execProc   = ThreadSendEval;
        sendPtr->freeProc   = threadSendFree;
        sendPtr->clientData = (ClientData) Tcl_Merge(3, argv);
        sendPtr->interp     = NULL;

        ThreadSend(interp, errorThreadId, sendPtr, NULL, 0);
    }
}
 
/*
................................................................................
        return 0;
    }

    /*
     * Allocate storage for passing thread id's to caller
     */

    *thrIdArray = (Tcl_ThreadId*)ckalloc(count * sizeof(Tcl_ThreadId));

    /*
     * Second walk; fill-in the array with thread ID's
     */

    for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) {
        (*thrIdArray)[ii] = tsdPtr->threadId;
................................................................................
    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    if (result != NULL) {
        resultObj = Tcl_NewStringObj(result, TCL_STRLEN);
    }

    code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);

    Tcl_MutexUnlock(&threadMutex);
    return code;
}
................................................................................
     *      transfer. This allows this thread then to proceed.
     */

    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_STRLEN));
    }
    if (Tcl_IsChannelShared(chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_STRLEN));
        return TCL_ERROR;
    }

    /*
     * Short circuit transfers to ourself.  Nothing to do.
     */

................................................................................

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into an event.
     */

    resultPtr = (TransferResult*)ckalloc(sizeof(TransferResult));
    evPtr     = (TransferEvent *)ckalloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = TransferEventProc;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields.
................................................................................
        Tcl_SpliceChannel(chan);
        Tcl_RegisterChannel(interp, chan);
        Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
        Tcl_AppendResult(interp, "transfer failed: ", NULL);

        if (resultPtr->resultMsg) {
            Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
            ckfree(resultPtr->resultMsg);
        } else {
            Tcl_AppendResult(interp, "for reasons unknown", NULL);
        }
        ckfree((char *)resultPtr);

        return TCL_ERROR;
    }

    if (resultPtr->resultMsg) {
        ckfree(resultPtr->resultMsg);
    }
    ckfree((char *)resultPtr);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Tcl_Interp *interp;         /* The current interpreter. */
    Tcl_Channel chan;           /* The channel to detach */
{
    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_STRLEN));
    }
    if (Tcl_IsChannelShared(chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_STRLEN));
        return TCL_ERROR;
    }

    /*
     * Cut the channel out of the interp/thread
     */

................................................................................
    /*
     * Wrap it into the list of transfered channels. We generate no
     * events associated with the detached channel, thus really not
     * needing the transfer event structure allocated here. This
     * is done purely to avoid having yet another wrapper.
     */

    resultPtr = (TransferResult*)ckalloc(sizeof(TransferResult));
    evPtr     = (TransferEvent*)ckalloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = NULL;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields. This is not used.
................................................................................
                && !resPtr->dstThreadId) {
            if (Tcl_IsChannelExisting(chanName)) {
                Tcl_MutexUnlock(&threadMutex);
                Tcl_AppendResult(interp, "channel already exists", NULL);
                return TCL_ERROR;
            }
            SpliceOut(resPtr, transferList);
            ckfree((char*)resPtr->eventPtr);
            ckfree((char*)resPtr);
            found = 1;
            break;
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    if (found == 0) {
................................................................................

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL
            || (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
        int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
        Tcl_MutexUnlock(&threadMutex);
        ThreadFreeProc((ClientData)send);
        if (clbk) {
            ThreadFreeProc((ClientData)clbk);
        }
        if (inerror) {
        	Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_STRLEN));
        } else {
            ErrorNoSuchThread(interp, thrId);
        }
        return TCL_ERROR;
    }

    /*
     * Short circuit sends to ourself.
     */

    if (thrId == Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        if ((flags & THREAD_SEND_WAIT)) {
            int code = (*send->execProc)(interp, (ClientData)send);
            ThreadFreeProc((ClientData)send);
            return code;
        } else {
            send->interp = interp;
            Tcl_Preserve((ClientData)send->interp);
            Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, (ClientData)send);
            return TCL_OK;
        }
    }

    /*
     * Create the event for target thread event queue.
     */

    eventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
    eventPtr->sendData = send;
    eventPtr->clbkData = clbk;

    /*
     * Target thread about to service
     * another event
     */
................................................................................

    /*
     * Caller wants to be notified, so we must take care
     * it's interpreter stays alive until we've finished.
     */

    if (eventPtr->clbkData) {
        Tcl_Preserve((ClientData)eventPtr->clbkData->interp);
    }
    if ((flags & THREAD_SEND_WAIT) == 0) {
        resultPtr              = NULL;
        eventPtr->resultPtr    = NULL;
    } else {
        resultPtr = (ThreadEventResult*)ckalloc(sizeof(ThreadEventResult));
        resultPtr->done        = (Tcl_Condition)NULL;
        resultPtr->result      = NULL;
        resultPtr->errorCode   = NULL;
        resultPtr->errorInfo   = NULL;
        resultPtr->dstThreadId = thrId;
        resultPtr->srcThreadId = Tcl_GetCurrentThread();
        resultPtr->eventPtr    = eventPtr;
................................................................................
    /*
     * Return result to caller
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
            ckfree(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
        	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_STRLEN));
            ckfree(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, TCL_STRLEN));

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);
    if (resultPtr->result != threadEmptyResult) {
        ckfree(resultPtr->result);
    }
    ckfree((char*)resultPtr);

    return code;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
             * It should immediately exit thereafter. We might get
             * stuck here for long time if user really wants to
             * be absolutely sure that the thread has exited.
             */

            if (dowait) {
                resultPtr = (ThreadEventResult*)
                    ckalloc(sizeof(ThreadEventResult));
                resultPtr->done        = (Tcl_Condition)NULL;
                resultPtr->result      = NULL;
                resultPtr->code        = TCL_OK;
                resultPtr->errorCode   = NULL;
                resultPtr->errorInfo   = NULL;
                resultPtr->dstThreadId = thrId;
                resultPtr->srcThreadId = Tcl_GetCurrentThread();
                SpliceIn(resultPtr, resultList);
            }

            evPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
            evPtr->event.proc = ThreadEventProc;
            evPtr->sendData   = NULL;
            evPtr->clbkData   = NULL;
            evPtr->resultPtr  = resultPtr;

            Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
            Tcl_ThreadAlert(thrId);
................................................................................
            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                if (resultPtr->result != threadEmptyResult) {
                    ckfree(resultPtr->result); /* Will be ignored anyway */
                }
                ckfree((char*)resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);

................................................................................
     * async callback script. In this case, interpreter will be
     * changed to one given in the callback.
     */

    interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp;

    if (interp != NULL) {
        Tcl_Preserve((ClientData)interp);

        if (clbkPtr && clbkPtr->threadId == thrId) {
            Tcl_Release((ClientData)interp);
            /* Watch: this thread evaluates its own callback. */
            interp = clbkPtr->interp;
            Tcl_Preserve((ClientData)interp);
        }

        Tcl_ResetResult(interp);

        if (sendPtr) {
            Tcl_CreateThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
            if (clbkPtr) {
                Tcl_CreateThreadExitHandler(ThreadFreeProc,
                                            (ClientData)clbkPtr);
            }
            code = (*sendPtr->execProc)(interp, (ClientData)sendPtr);
            Tcl_DeleteThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
            if (clbkPtr) {
                Tcl_DeleteThreadExitHandler(ThreadFreeProc,
                                            (ClientData)clbkPtr);
            }
        } else {
            code = TCL_OK;
        }
    }

    if (sendPtr) {
        ThreadFreeProc((ClientData)sendPtr);
        eventPtr->sendData = NULL;
    }

    if (resultPtr) {

        /*
         * Report job result synchronously to waiting caller
................................................................................
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release((ClientData)clbkPtr->interp);
        }
    } else if (clbkPtr && clbkPtr->threadId != thrId) {

        ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr;

        /*
         * Route the callback back to it's originator.
................................................................................
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release((ClientData)clbkPtr->interp);
        }
    } else {
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release((ClientData)clbkPtr->interp);
        }
    }

    if (interp != NULL) {
        Tcl_Release((ClientData)interp);
    }

    /*
     * Mark unwind scenario for this thread if the script resulted
     * in error condition and thread has been marked to unwind.
     * This will cause thread to disappear from the list of active
     * threads, clean-up its event queue and exit.
................................................................................
    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";
        result    = "no target interp!";
        size    = strlen(result);
        resultPtr->result = (size) ?
            memcpy(ckalloc(1+size), result, 1+size) : threadEmptyResult;
    } else {
        result = Tcl_GetString(Tcl_GetObjResult(interp));
        size = Tcl_GetObjResult(interp)->length;
        resultPtr->result = (size) ?
            memcpy(ckalloc(1+size), result, 1+size) : threadEmptyResult;
        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }

    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = memcpy(ckalloc(size), errorCode, size);
    } else {
        resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
        size = strlen(errorInfo) + 1;
        resultPtr->errorInfo = memcpy(ckalloc(size), errorInfo, size);
    } else {
        resultPtr->errorInfo = NULL;
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 * Side effects.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadIdleProc(clientData)
    ClientData clientData;
{
    int ret;
    ThreadSendData *sendPtr = (ThreadSendData*)clientData;

    ret = (*sendPtr->execProc)(sendPtr->interp, (ClientData)sendPtr);
    if (ret != TCL_OK) {
        ThreadErrorProc(sendPtr->interp);
    }

    Tcl_Release((ClientData)sendPtr->interp);
    ThreadFreeProc(clientData);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TransferEventProc --
................................................................................
        }
    }
    if (resultPtr) {
        Tcl_MutexLock(&threadMutex);
        resultPtr->resultCode = code;
        if (msg != NULL) {
            size_t size = strlen(msg)+1;
            resultPtr->resultMsg = memcpy(ckalloc(size), msg, size);
        }
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}
................................................................................
 *
 *  Called when we are exiting and memory needs to be freed.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Clears up mem specified in ClientData
 *
 *----------------------------------------------------------------------
 */
static void
ThreadFreeProc(clientData)
    ClientData clientData;
{
    /*
     * This will free send and/or callback structures
     * since both are the same in the beginning.
     */

    ThreadSendData *anyPtr = (ThreadSendData*)clientData;

    if (anyPtr) {
        if (anyPtr->clientData) {
            (*anyPtr->freeProc)(anyPtr->clientData);
        }
        ckfree((char*)anyPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadDeleteEvent --
................................................................................
 *  It cleans up our events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadDeleteEvent(eventPtr, clientData)
    Tcl_Event *eventPtr;        /* Really ThreadEvent */
    ClientData clientData;      /* dummy */
{
    if (eventPtr->proc == ThreadEventProc) {
        /*
         * Regular script event. Just dispose memory
         */
        ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
        if (evPtr->sendData) {
            ThreadFreeProc((ClientData)evPtr->sendData);
            evPtr->sendData = NULL;
        }
        if (evPtr->clbkData) {
            ThreadFreeProc((ClientData)evPtr->clbkData);
            evPtr->clbkData = NULL;
        }
        return 1;
    }
    if (eventPtr->proc == TransferEventProc) {
        /*
         * A channel is in flight toward the thread just exiting.
................................................................................
 *  It unblocks anyone that is waiting on a send to this thread.
 *  It cleans up any events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static void
ThreadExitProc(clientData)
    ClientData clientData;
{
    char *threadEvalScript = (char*)clientData;
    const char *diemsg = "target thread died";
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TransferResult *tResultPtr, *tNextPtr;

    if (threadEvalScript && threadEvalScript != threadEmptyResult) {
        ckfree((char*)threadEvalScript);
    }

    Tcl_MutexLock(&threadMutex);

    /*
     * NaviServer/AOLserver and threadpool threads get started/stopped
     * out of the control of this interface so this is
................................................................................

            /*
             * We are going away. By freeing up the result we signal
             * to the other thread we don't care about the result.
             */

            SpliceOut(resultPtr, resultList);
            ckfree((char*)resultPtr);

        } else if (resultPtr->dstThreadId == self) {

            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            resultPtr->result = strcpy(ckalloc(1+strlen(diemsg)), diemsg);
            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;
................................................................................
             * to the other thread we don't care about the result.
             *
             * This should not happen, as this thread should be in
             * ThreadTransfer at location (*).
             */

            SpliceOut(tResultPtr, transferList);
            ckfree((char*)tResultPtr);

        } else if (tResultPtr->dstThreadId == self) {
            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            tResultPtr->resultMsg = strcpy(ckalloc(1+strlen(diemsg)),
                                           diemsg);
            tResultPtr->resultCode = TCL_ERROR;
            Tcl_ConditionNotify(&tResultPtr->done);
        }
    }
    Tcl_MutexUnlock(&threadMutex);
}






|







 







|
|







 







|







|







 







|







 







|


|


|


|







 







|







 







|

|


|







 







|
|
<












|

|


|







 







|

|







 







|

|







 







|

|







 







|

|












|







 







|

|







 







|







 







|

|




|

|







 







|









|




|






|



|







 







|

|







 







|

|



|







 







|

|







 







|

|







 







|



|








|












|






|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|


|







 







|

|
|









|



|







 







|
|



|
|







 







|


|







 







|







 







|

|







 







|
|







 







|







 







|







 







|
|

|








|


|







 







|







 







|







 







|


|







 







|
|







 







|



|





|

|







 







|


|







 







|
|







 







|
|







 







|

|


|













|
|



|
|








|







 







|





|







 







|


|
|




|







|

|







 







|










|







 







|

|







 







|


|


|





|


|

|
|


|







|







 







|







 







|









|




|







 







|




|













|





|







 







|


|

|




|







 







|







 







|





|






|





|







 







|







|



|







 







|

|








|







 







|









|







 







|








|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
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
...
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
...
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
...
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
...
560
561
562
563
564
565
566
567
568

569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
...
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
...
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
...
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
...
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
...
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
...
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
...
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
...
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
....
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
....
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
....
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
....
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
....
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
....
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
....
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
....
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
....
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
....
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
....
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
....
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
....
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
....
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
....
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
....
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
....
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
....
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
....
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
....
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
....
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
....
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
....
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
....
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
....
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
....
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
....
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
....
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
....
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
....
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
....
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
....
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
....
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
....
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
....
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
....
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
....
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
....
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
....
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
....
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
....
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
....
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
....
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
....
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
....
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
typedef struct ThreadCtrl {
    char *script;                         /* Script to execute */
    int flags;                            /* Initial value of the "flags"
                                           * field in ThreadSpecificData */
    Tcl_Condition condWait;               /* Condition variable used to
                                           * sync parent and child threads */
    void *cd;                        /* Opaque ptr to pass to thread */
} ThreadCtrl;

/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
................................................................................
    Tcl_Event event;                      /* Must be first */
    struct ThreadSendData *sendData;      /* See below */
    struct ThreadClbkData *clbkData;      /* See below */
    struct ThreadEventResult *resultPtr;  /* To communicate the result back.
                                           * NULL if we don't care about it */
} ThreadEvent;

typedef int  (ThreadSendProc) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */

/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
................................................................................
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements identical!
 */

typedef struct ThreadSendData {
    ThreadSendProc *execProc;             /* Func to exec in remote thread */
    void *clientData;                     /* Ptr to pass to send function */
    ThreadSendFree *freeProc;             /* Function to free client data */
     /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
} ThreadSendData;

typedef struct ThreadClbkData {
    ThreadSendProc *execProc;             /* The callback function */
    void *clientData;                     /* Ptr to pass to clbk function */
    ThreadSendFree *freeProc;             /* Function to free client data */
    /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
    Tcl_ThreadId threadId;                /* Thread where to post callback */
    ThreadEventResult result;             /* Returns result asynchronously */
} ThreadClbkData;

................................................................................
/*
 * Miscellaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread(void *clientData);

static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);

static int
ThreadInit(Tcl_Interp *interp);

................................................................................
static int
ThreadList(Tcl_Interp *interp,
                               Tcl_ThreadId **thrIdArray);
static void
ThreadErrorProc(Tcl_Interp *interp);

static void
ThreadFreeProc(void *clientData);

static void
ThreadIdleProc(void *clientData);

static void
ThreadExitProc(void *clientData);

static void
ThreadFreeError(void *clientData);

static void
ListRemove(ThreadSpecificData *tsdPtr);

static void
ListRemoveInner(ThreadSpecificData *tsdPtr);

................................................................................
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->interp == (Tcl_Interp*)NULL) {
        memset(tsdPtr, 0, sizeof(ThreadSpecificData));
        tsdPtr->interp = interp;
        ListUpdate(tsdPtr);
        Tcl_CreateThreadExitHandler(ThreadExitProc,
                                    threadEmptyResult);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadCreateObjCmd --
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCreateObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int   objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int argc, rsrv = 0;
    const char *arg, *script;
    int flags = TCL_THREAD_NOFLAGS;

    Init(interp);

    /*
     * Syntax: thread::create ?-joinable? ?-preserved? ?script?
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadReserveObjCmd --
 *
 *  This procedure is invoked to process the "thread::preserve" and
 *  "thread::release" Tcl commands. See the user documentation for
 *  details on it does.

 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserveObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId = NULL;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?threadId?");
        return TCL_ERROR;
    }
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReleaseObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int wait = 0;
    Tcl_ThreadId thrId = (Tcl_ThreadId)0;

    Init(interp);

................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadUnwindObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
................................................................................
 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExitObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int status = 666;

    Init(interp);

    if (objc > 2) {
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadIdObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char thrHandle[THREAD_HNDLMAXLEN];

    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_AUTO_LENGTH));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadNamesObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, length;
    char *result, thrHandle[THREAD_HNDLMAXLEN];
    Tcl_ThreadId *thrIdArray;
    Tcl_DString threadNames;

................................................................................

    length = Tcl_DStringLength(&threadNames);
    result = Tcl_DStringValue(&threadNames);

    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));

    Tcl_DStringFree(&threadNames);
    Tcl_Free(thrIdArray);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}

static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t size;
    int ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;
................................................................................
        const char *varName = Tcl_GetString(var);
        size_t vsize = var->length + 1;

        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_AUTO_LENGTH));
            return TCL_ERROR;
        }

        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = Tcl_Alloc(sizeof(ThreadClbkData));
        clbkPtr->execProc   = ThreadClbkSetVar;
        clbkPtr->freeProc   = threadSendFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = memcpy(Tcl_Alloc(vsize), varName, vsize);
    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = Tcl_Alloc(sizeof(ThreadSendData));
    sendPtr->interp     = NULL; /* Signal to use thread main interp */
    sendPtr->execProc   = ThreadSendEval;
    sendPtr->freeProc   = threadSendFree;
    sendPtr->clientData = memcpy(Tcl_Alloc(size), script, size);

    ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);

    if (var && (flags & THREAD_SEND_WAIT)) {

        /*
         * Leave job's result in passed variable
................................................................................
 *  Script is sent to all known threads except the caller thread.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadBroadcastObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, nthreads;
    size_t size;
    const char *script;
    Tcl_ThreadId *thrIdArray;
    ThreadSendData *sendPtr, job;
................................................................................
     * to the head of the event queue (as out-of-band message).
     */

    for (ii = 0; ii < nthreads; ii++) {
        if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
            continue; /* Do not broadcast self */
        }
        sendPtr  = Tcl_Alloc(sizeof(ThreadSendData));
        *sendPtr = job;
        sendPtr->clientData = memcpy(Tcl_Alloc(size), script, size);
        ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
    }

    Tcl_Free(thrIdArray);
    Tcl_ResetResult(interp);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *  Enters the event loop.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadWaitObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
................................................................................
 *  Registers an errorproc.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadErrorProcObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t len;
    char *proc;

    Init(interp);

................................................................................
    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
        return TCL_ERROR;
    }
    Tcl_MutexLock(&threadMutex);
    if (objc == 1) {
        if (errorProcString) {
        	Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_AUTO_LENGTH));
        }
    } else {
        if (errorProcString) {
            Tcl_Free(errorProcString);
        }
        proc = Tcl_GetString(objv[1]);
        len = objv[1]->length;
        if (len == 0) {
            errorThreadId = NULL;
            errorProcString = NULL;
        } else {
            errorThreadId = Tcl_GetCurrentThread();
            errorProcString = Tcl_Alloc(1+strlen(proc));
            strcpy(errorProcString, proc);
            Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
            Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}
 
static void
ThreadFreeError(clientData)
    void *clientData;
{
    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        return;
    }
    Tcl_Free(errorProcString);
    errorThreadId = NULL;
    errorProcString = NULL;
    Tcl_MutexUnlock(&threadMutex);
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadJoinObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadTransferObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    Tcl_ThreadId thrId;
    Tcl_Channel chan;

    Init(interp);
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadDetachObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_Channel chan;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadAttachObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *chanName;

    Init(interp);

    /*
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExistsObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    if (objc != 2) {
................................................................................
 *
 * Side effects:
 *  None.
 *----------------------------------------------------------------------
 */
static int
ThreadConfigureObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *option, *value;
    Tcl_ThreadId thrId;         /* Id of the thread to configure */
    int i;                      /* Iterate over arg-value pairs. */
    Tcl_DString ds;             /* DString to hold result of
                                 * calling GetThreadOption. */
................................................................................
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancelObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;
    int ii, flags;
    const char *result;

    if ((objc < 2) || (objc > 4)) {
................................................................................
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSendEval(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{
    ThreadSendData *sendPtr = clientData;
    char *script = (char*)sendPtr->clientData;

    return Tcl_EvalEx(interp, script, TCL_AUTO_LENGTH, TCL_EVAL_GLOBAL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadClbkSetVar --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{
    ThreadClbkData *clbkPtr = clientData;
    const char *var = clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */

    valObj = Tcl_NewStringObj(resultPtr->result, TCL_AUTO_LENGTH);
    Tcl_IncrRefCount(valObj);

    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }

    /*
     * Set the result variable
     */

    if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
................................................................................
    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            var = "errorCode";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorCode, TCL_AUTO_LENGTH), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            var = "errorInfo";
            Tcl_SetVar2Ex(interp, var, NULL, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundException(interp, TCL_ERROR);
    }

cleanup:
    Tcl_DecrRefCount(valObj);
................................................................................

    ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL);
    ctrl.script   = (char *)script;
    ctrl.condWait = NULL;
    ctrl.flags    = 0;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&thrId, NewThread, &ctrl,
            stacksize, flags) != TCL_OK) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_AUTO_LENGTH));
        return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using
     * the ThreadCtrl argument which is on our stack.
     */
................................................................................
        tsdPtr->refCount++;
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ConditionFinalize(&ctrl.condWait);

    ThreadGetHandle(thrId, thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_AUTO_LENGTH));

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
 *    A Tcl script is executed in a new thread.
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadCreateType
NewThread(clientData)
    void *clientData;
{
    ThreadCtrl *ctrlPtr = clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK, scriptLen;
    char *evalScript;

    /*
     * Initialize the interpreter. The bad thing here is that we
................................................................................

    /*
     * We need to keep a pointer to the alloc'ed mem of the script
     * we are eval'ing, for the case that we exit during evaluation
     */

    scriptLen = strlen(ctrlPtr->script);
    evalScript = strcpy(Tcl_Alloc(scriptLen+1), ctrlPtr->script);
    Tcl_CreateThreadExitHandler(ThreadExitProc, evalScript);

    /*
     * Notify the parent we are alive.
     */

    ctrlPtr->script = NULL;
    Tcl_ConditionNotify(&ctrlPtr->condWait);
................................................................................

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve(tsdPtr->interp);
    result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
        ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up. Note: add something like TlistRemove for the transfer list.
................................................................................

#ifdef NS_AOLSERVER
    Ns_TclMarkForDelete(tsdPtr->interp);
    Ns_TclDeAllocateInterp(tsdPtr->interp);
#else
    Tcl_DeleteInterp(tsdPtr->interp);
#endif
    Tcl_Release(tsdPtr->interp);

    /*tsdPtr->interp = NULL;*/

    /*
     * Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls
     * ThreadExitHandlers and cleans the notifier as well as other sub-
     * systems that save thread state data.
................................................................................
        Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
        if (errChannel == NULL) {
            /* Fixes the [#634845] bug; credits to
             * Wojciech Kocjan <[email protected]> */
            return;
        }
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_WriteChars(errChannel, "Error from thread ", TCL_AUTO_LENGTH);
        Tcl_WriteChars(errChannel, buf, TCL_AUTO_LENGTH);
        Tcl_WriteChars(errChannel, "\n", 1);
        Tcl_WriteChars(errChannel, errorInfo, TCL_AUTO_LENGTH);
        Tcl_WriteChars(errChannel, "\n", 1);
#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = Tcl_Alloc(sizeof(ThreadSendData));
        sendPtr->execProc   = ThreadSendEval;
        sendPtr->freeProc   = threadSendFree;
        sendPtr->clientData = Tcl_Merge(3, argv);
        sendPtr->interp     = NULL;

        ThreadSend(interp, errorThreadId, sendPtr, NULL, 0);
    }
}
 
/*
................................................................................
        return 0;
    }

    /*
     * Allocate storage for passing thread id's to caller
     */

    *thrIdArray = Tcl_Alloc(count * sizeof(Tcl_ThreadId));

    /*
     * Second walk; fill-in the array with thread ID's
     */

    for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) {
        (*thrIdArray)[ii] = tsdPtr->threadId;
................................................................................
    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    if (result != NULL) {
        resultObj = Tcl_NewStringObj(result, TCL_AUTO_LENGTH);
    }

    code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);

    Tcl_MutexUnlock(&threadMutex);
    return code;
}
................................................................................
     *      transfer. This allows this thread then to proceed.
     */

    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_AUTO_LENGTH));
    }
    if (Tcl_IsChannelShared(chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_AUTO_LENGTH));
        return TCL_ERROR;
    }

    /*
     * Short circuit transfers to ourself.  Nothing to do.
     */

................................................................................

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into an event.
     */

    resultPtr = Tcl_Alloc(sizeof(TransferResult));
    evPtr     = Tcl_Alloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = TransferEventProc;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields.
................................................................................
        Tcl_SpliceChannel(chan);
        Tcl_RegisterChannel(interp, chan);
        Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
        Tcl_AppendResult(interp, "transfer failed: ", NULL);

        if (resultPtr->resultMsg) {
            Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
            Tcl_Free(resultPtr->resultMsg);
        } else {
            Tcl_AppendResult(interp, "for reasons unknown", NULL);
        }
        Tcl_Free(resultPtr);

        return TCL_ERROR;
    }

    if (resultPtr->resultMsg) {
        Tcl_Free(resultPtr->resultMsg);
    }
    Tcl_Free(resultPtr);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Tcl_Interp *interp;         /* The current interpreter. */
    Tcl_Channel chan;           /* The channel to detach */
{
    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_AUTO_LENGTH));
    }
    if (Tcl_IsChannelShared(chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_AUTO_LENGTH));
        return TCL_ERROR;
    }

    /*
     * Cut the channel out of the interp/thread
     */

................................................................................
    /*
     * Wrap it into the list of transfered channels. We generate no
     * events associated with the detached channel, thus really not
     * needing the transfer event structure allocated here. This
     * is done purely to avoid having yet another wrapper.
     */

    resultPtr = Tcl_Alloc(sizeof(TransferResult));
    evPtr     = Tcl_Alloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = NULL;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields. This is not used.
................................................................................
                && !resPtr->dstThreadId) {
            if (Tcl_IsChannelExisting(chanName)) {
                Tcl_MutexUnlock(&threadMutex);
                Tcl_AppendResult(interp, "channel already exists", NULL);
                return TCL_ERROR;
            }
            SpliceOut(resPtr, transferList);
            Tcl_Free(resPtr->eventPtr);
            Tcl_Free(resPtr);
            found = 1;
            break;
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    if (found == 0) {
................................................................................

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL
            || (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
        int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
        Tcl_MutexUnlock(&threadMutex);
        ThreadFreeProc(send);
        if (clbk) {
            ThreadFreeProc(clbk);
        }
        if (inerror) {
        	Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_AUTO_LENGTH));
        } else {
            ErrorNoSuchThread(interp, thrId);
        }
        return TCL_ERROR;
    }

    /*
     * Short circuit sends to ourself.
     */

    if (thrId == Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        if ((flags & THREAD_SEND_WAIT)) {
            int code = (*send->execProc)(interp, send);
            ThreadFreeProc(send);
            return code;
        } else {
            send->interp = interp;
            Tcl_Preserve(send->interp);
            Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, send);
            return TCL_OK;
        }
    }

    /*
     * Create the event for target thread event queue.
     */

    eventPtr = Tcl_Alloc(sizeof(ThreadEvent));
    eventPtr->sendData = send;
    eventPtr->clbkData = clbk;

    /*
     * Target thread about to service
     * another event
     */
................................................................................

    /*
     * Caller wants to be notified, so we must take care
     * it's interpreter stays alive until we've finished.
     */

    if (eventPtr->clbkData) {
        Tcl_Preserve(eventPtr->clbkData->interp);
    }
    if ((flags & THREAD_SEND_WAIT) == 0) {
        resultPtr              = NULL;
        eventPtr->resultPtr    = NULL;
    } else {
        resultPtr = Tcl_Alloc(sizeof(ThreadEventResult));
        resultPtr->done        = (Tcl_Condition)NULL;
        resultPtr->result      = NULL;
        resultPtr->errorCode   = NULL;
        resultPtr->errorInfo   = NULL;
        resultPtr->dstThreadId = thrId;
        resultPtr->srcThreadId = Tcl_GetCurrentThread();
        resultPtr->eventPtr    = eventPtr;
................................................................................
    /*
     * Return result to caller
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
        	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH));
            Tcl_Free(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, TCL_AUTO_LENGTH));

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);
    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }
    Tcl_Free(resultPtr);

    return code;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
             * It should immediately exit thereafter. We might get
             * stuck here for long time if user really wants to
             * be absolutely sure that the thread has exited.
             */

            if (dowait) {
                resultPtr = (ThreadEventResult*)
                    Tcl_Alloc(sizeof(ThreadEventResult));
                resultPtr->done        = (Tcl_Condition)NULL;
                resultPtr->result      = NULL;
                resultPtr->code        = TCL_OK;
                resultPtr->errorCode   = NULL;
                resultPtr->errorInfo   = NULL;
                resultPtr->dstThreadId = thrId;
                resultPtr->srcThreadId = Tcl_GetCurrentThread();
                SpliceIn(resultPtr, resultList);
            }

            evPtr = Tcl_Alloc(sizeof(ThreadEvent));
            evPtr->event.proc = ThreadEventProc;
            evPtr->sendData   = NULL;
            evPtr->clbkData   = NULL;
            evPtr->resultPtr  = resultPtr;

            Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
            Tcl_ThreadAlert(thrId);
................................................................................
            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                if (resultPtr->result != threadEmptyResult) {
                    Tcl_Free(resultPtr->result); /* Will be ignored anyway */
                }
                Tcl_Free(resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);

................................................................................
     * async callback script. In this case, interpreter will be
     * changed to one given in the callback.
     */

    interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp;

    if (interp != NULL) {
        Tcl_Preserve(interp);

        if (clbkPtr && clbkPtr->threadId == thrId) {
            Tcl_Release(interp);
            /* Watch: this thread evaluates its own callback. */
            interp = clbkPtr->interp;
            Tcl_Preserve(interp);
        }

        Tcl_ResetResult(interp);

        if (sendPtr) {
            Tcl_CreateThreadExitHandler(ThreadFreeProc, sendPtr);
            if (clbkPtr) {
                Tcl_CreateThreadExitHandler(ThreadFreeProc,
                                            clbkPtr);
            }
            code = (*sendPtr->execProc)(interp, sendPtr);
            Tcl_DeleteThreadExitHandler(ThreadFreeProc, sendPtr);
            if (clbkPtr) {
                Tcl_DeleteThreadExitHandler(ThreadFreeProc,
                                            clbkPtr);
            }
        } else {
            code = TCL_OK;
        }
    }

    if (sendPtr) {
        ThreadFreeProc(sendPtr);
        eventPtr->sendData = NULL;
    }

    if (resultPtr) {

        /*
         * Report job result synchronously to waiting caller
................................................................................
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release(clbkPtr->interp);
        }
    } else if (clbkPtr && clbkPtr->threadId != thrId) {

        ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr;

        /*
         * Route the callback back to it's originator.
................................................................................
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release(clbkPtr->interp);
        }
    } else {
        /*
         * We still need to release the reference to the Tcl
         * interpreter added by ThreadSend whenever the callback
         * data is not NULL.
         */

        if (clbkPtr) {
            Tcl_Release(clbkPtr->interp);
        }
    }

    if (interp != NULL) {
        Tcl_Release(interp);
    }

    /*
     * Mark unwind scenario for this thread if the script resulted
     * in error condition and thread has been marked to unwind.
     * This will cause thread to disappear from the list of active
     * threads, clean-up its event queue and exit.
................................................................................
    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";
        result    = "no target interp!";
        size    = strlen(result);
        resultPtr->result = (size) ?
            memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
    } else {
        result = Tcl_GetString(Tcl_GetObjResult(interp));
        size = Tcl_GetObjResult(interp)->length;
        resultPtr->result = (size) ?
            memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }

    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = memcpy(Tcl_Alloc(size), errorCode, size);
    } else {
        resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
        size = strlen(errorInfo) + 1;
        resultPtr->errorInfo = memcpy(Tcl_Alloc(size), errorInfo, size);
    } else {
        resultPtr->errorInfo = NULL;
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 * Side effects.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadIdleProc(clientData)
    void *clientData;
{
    int ret;
    ThreadSendData *sendPtr = clientData;

    ret = (*sendPtr->execProc)(sendPtr->interp, sendPtr);
    if (ret != TCL_OK) {
        ThreadErrorProc(sendPtr->interp);
    }

    Tcl_Release(sendPtr->interp);
    ThreadFreeProc(clientData);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TransferEventProc --
................................................................................
        }
    }
    if (resultPtr) {
        Tcl_MutexLock(&threadMutex);
        resultPtr->resultCode = code;
        if (msg != NULL) {
            size_t size = strlen(msg)+1;
            resultPtr->resultMsg = memcpy(Tcl_Alloc(size), msg, size);
        }
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}
................................................................................
 *
 *  Called when we are exiting and memory needs to be freed.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Clears up mem specified in clientData
 *
 *----------------------------------------------------------------------
 */
static void
ThreadFreeProc(clientData)
    void *clientData;
{
    /*
     * This will free send and/or callback structures
     * since both are the same in the beginning.
     */

    ThreadSendData *anyPtr = clientData;

    if (anyPtr) {
        if (anyPtr->clientData) {
            (*anyPtr->freeProc)(anyPtr->clientData);
        }
        Tcl_Free(anyPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThreadDeleteEvent --
................................................................................
 *  It cleans up our events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadDeleteEvent(eventPtr, clientData)
    Tcl_Event *eventPtr;        /* Really ThreadEvent */
    void *clientData;      /* dummy */
{
    if (eventPtr->proc == ThreadEventProc) {
        /*
         * Regular script event. Just dispose memory
         */
        ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
        if (evPtr->sendData) {
            ThreadFreeProc(evPtr->sendData);
            evPtr->sendData = NULL;
        }
        if (evPtr->clbkData) {
            ThreadFreeProc(evPtr->clbkData);
            evPtr->clbkData = NULL;
        }
        return 1;
    }
    if (eventPtr->proc == TransferEventProc) {
        /*
         * A channel is in flight toward the thread just exiting.
................................................................................
 *  It unblocks anyone that is waiting on a send to this thread.
 *  It cleans up any events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static void
ThreadExitProc(clientData)
    void *clientData;
{
    char *threadEvalScript = clientData;
    const char *diemsg = "target thread died";
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TransferResult *tResultPtr, *tNextPtr;

    if (threadEvalScript && threadEvalScript != threadEmptyResult) {
        Tcl_Free(threadEvalScript);
    }

    Tcl_MutexLock(&threadMutex);

    /*
     * NaviServer/AOLserver and threadpool threads get started/stopped
     * out of the control of this interface so this is
................................................................................

            /*
             * We are going away. By freeing up the result we signal
             * to the other thread we don't care about the result.
             */

            SpliceOut(resultPtr, resultList);
            Tcl_Free(resultPtr);

        } else if (resultPtr->dstThreadId == self) {

            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg);
            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;
................................................................................
             * to the other thread we don't care about the result.
             *
             * This should not happen, as this thread should be in
             * ThreadTransfer at location (*).
             */

            SpliceOut(tResultPtr, transferList);
            Tcl_Free(tResultPtr);

        } else if (tResultPtr->dstThreadId == self) {
            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

            tResultPtr->resultMsg = strcpy(Tcl_Alloc(1+strlen(diemsg)),
                                           diemsg);
            tResultPtr->resultCode = TCL_ERROR;
            Tcl_ConditionNotify(&tResultPtr->done);
        }
    }
    Tcl_MutexUnlock(&threadMutex);
}

Changes to generic/threadNs.c.

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    int ret = Thread_Init(interp);

    if (ret != TCL_OK) {
        Ns_Log(Warning, "can't load module %s: %s", md->modname,
                Tcl_GetString(Tcl_GetObjResult(interp)));
        return TCL_ERROR;
    }
    Tcl_SetAssocData(interp, "thread:nsd", NULL, (ClientData)md);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------------
 *






|







39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    int ret = Thread_Init(interp);

    if (ret != TCL_OK) {
        Ns_Log(Warning, "can't load module %s: %s", md->modname,
                Tcl_GetString(Tcl_GetObjResult(interp)));
        return TCL_ERROR;
    }
    Tcl_SetAssocData(interp, "thread:nsd", NULL, md);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------------
 *

Changes to generic/threadPoolCmd.c.

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
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
...
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
...
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
...
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
...
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
...
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
...
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
...
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
...
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
...
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
...
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
...
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
...
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
....
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
....
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
....
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
....
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
....
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
....
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
....
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
....
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
....
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
....
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
....
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
....
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
....
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
....
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
 * Structure for passing evaluation results
 */

typedef struct TpoolResult {
    int detached;                   /* Result is to be ignored */
    Tcl_WideInt jobId;              /* The job id of the current job */
    char *script;                   /* Script to evaluate in worker thread */
    STRLEN_TYPE scriptLen;          /* Length of the script */
    int retcode;                    /* Tcl return code of the current job */
    char *result;                   /* Tcl result of the current job */
    char *errorCode;                /* On error: content of the errorCode */
    char *errorInfo;                /* On error: content of the errorInfo */
    Tcl_ThreadId threadId;          /* Originating thread id */
    ThreadPool *tpoolPtr;           /* Current thread pool */
    struct TpoolResult *nextPtr;
................................................................................
 * Miscelaneous functions used within this file
 */

static int
CreateWorker(Tcl_Interp *interp, ThreadPool *tpoolPtr);

static Tcl_ThreadCreateType
TpoolWorker(ClientData clientData);

static int
RunStopEvent(Tcl_Event *evPtr, int mask);

static void
PushWork(TpoolResult *rPtr, ThreadPool *tpoolPtr);

................................................................................
static TpoolWaiter*
PopWaiter(ThreadPool *tpoolPtr);

static void
SignalWaiter(ThreadPool *tpoolPtr);

static int
TpoolEval(Tcl_Interp *interp, char *script, STRLEN_TYPE scriptLen,
                            TpoolResult *rPtr);
static void
SetResult(Tcl_Interp *interp, TpoolResult *rPtr);

static ThreadPool*
GetTpool(const char *tpoolName);

static ThreadPool*
GetTpoolUnl(const char *tpoolName);

static void
ThrExitHandler(ClientData clientData);

static void
AppExitHandler(ClientData clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static int
TpoolRelease(ThreadPool *tpoolPtr);

................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolCreateObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, minw, maxw, idle;
    char buf[64], *exs = NULL, *cmd = NULL;
    ThreadPool *tpoolPtr;

    /*
................................................................................
            }
        } else if (OPT_CMP(opt, "-idletime")) {
            if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) {
                return TCL_ERROR;
            }
        } else if (OPT_CMP(opt, "-initcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            cmd  = strcpy(ckalloc(objv[ii+1]->length+1), val);
        } else if (OPT_CMP(opt, "-exitcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            exs  = strcpy(ckalloc(objv[ii+1]->length+1), val);
        } else {
            goto usage;
        }
    }

    /*
     * Do some consistency checking
................................................................................
        maxw = minw;
    }

    /*
     * Allocate and initialize thread pool structure
     */

    tpoolPtr = (ThreadPool*)ckalloc(sizeof(ThreadPool));
    memset(tpoolPtr, 0, sizeof(ThreadPool));

    tpoolPtr->minWorkers  = minw;
    tpoolPtr->maxWorkers  = maxw;
    tpoolPtr->idleTime    = idle;
    tpoolPtr->initScript  = cmd;
    tpoolPtr->exitScript  = exs;
................................................................................
            Tcl_MutexUnlock(&listMutex);
            return TCL_ERROR;
        }
    }
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_STRLEN));

    return TCL_OK;

 usage:
    Tcl_WrongNumArgs(interp, 1, objv,
                     "?-minworkers count? ?-maxworkers count? "
                     "?-initcmd script? ?-exitcmd script? "
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolPostObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_WideInt jobId = 0;
    int ii, detached = 0, nowait = 0;
    size_t len;
    const char *tpoolName, *script;
    TpoolResult *rPtr;
................................................................................
        }
    }

    /*
     * Create new job ticket and put it on the list.
     */

    rPtr = (TpoolResult*)ckalloc(sizeof(TpoolResult));
    memset(rPtr, 0, sizeof(TpoolResult));

    if (detached == 0) {
        jobId = ++tpoolPtr->jobId;
        rPtr->jobId = jobId;
    }

    rPtr->script    = strcpy(ckalloc(len+1), script);
    rPtr->scriptLen = len;
    rPtr->detached  = detached;
    rPtr->threadId  = Tcl_GetCurrentThread();

    PushWork(rPtr, tpoolPtr);
    Tcl_ConditionNotify(&tpoolPtr->cond);
    Tcl_MutexUnlock(&tpoolPtr->mutex);
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolWaitObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, done;
    STRLEN_TYPE wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *waitList, *doneList, **wObjv;
    ThreadPool *tpoolPtr;
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolCancelObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii;
    STRLEN_TYPE wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *doneList, *waitList, **wObjv;
    ThreadPool *tpoolPtr;
    TpoolResult *rPtr;

................................................................................
                }
                if (rPtr->nextPtr != NULL) {
                    rPtr->nextPtr->prevPtr = rPtr->prevPtr;
                } else {
                    tpoolPtr->workTail = rPtr->prevPtr;
                }
                SetResult(NULL, rPtr); /* Just to free the result */
                ckfree(rPtr->script);
                ckfree((char*)rPtr);
                Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]);
                break;
            }
        }
        if (rPtr == NULL && listVar) {
            Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]);
        }
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolGetObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *resVar = NULL;
    ThreadPool *tpoolPtr;
................................................................................
    }

    Tcl_DeleteHashEntry(hPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    ret = rPtr->retcode;
    SetResult(interp, rPtr);
    ckfree((char*)rPtr);

    if (resVar) {
        Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0);
        Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
        ret = TCL_OK;
    }

................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReserveObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReleaseObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolSuspendObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::suspend tpoolId
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolResumeObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::resume tpoolId
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolNamesObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    STRLEN_TYPE objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    ThreadPool *tpoolPtr;
    Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);

    Tcl_MutexLock(&listMutex);
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) {
        char buf[32];
        sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
        Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_STRLEN));
    }
    Tcl_MutexUnlock(&listMutex);
    Tcl_SetObjResult(interp, listObj);

    return TCL_OK;
}
 
................................................................................

    /*
     * Create new worker thread here. Wait for the thread to start
     * because it's using the ThreadResult arg which is on our stack.
     */

    Tcl_MutexLock(&startMutex);
    if (Tcl_CreateThread(&id, TpoolWorker, (ClientData)&result,
                         TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_STRLEN));
        Tcl_MutexUnlock(&startMutex);
        return TCL_ERROR;
    }
    while(result.retcode == -1) {
        Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL);
    }
    Tcl_MutexUnlock(&startMutex);
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_ThreadCreateType
TpoolWorker(clientData)
    ClientData clientData;
{
    TpoolResult          *rPtr = (TpoolResult*)clientData;
    ThreadPool       *tpoolPtr = rPtr->tpoolPtr;

    int tout = 0;
    Tcl_Interp *interp;
    Tcl_Time waitTime, *idlePtr;
    const char *errMsg;

................................................................................
    } else {
        rPtr->retcode = 0;
    }
#endif

    if (rPtr->retcode == 1) {
        errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
        rPtr->result = strcpy(ckalloc(strlen(errMsg)+1), errMsg);
        Tcl_ConditionNotify(&tpoolPtr->cond);
        Tcl_MutexUnlock(&startMutex);
        goto out;
    }

    /*
     * Initialize the interpreter
     */

    if (tpoolPtr->initScript) {
        TpoolEval(interp, tpoolPtr->initScript, TCL_STRLEN, rPtr);
        if (rPtr->retcode != TCL_OK) {
            rPtr->retcode = 1;
            errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
            rPtr->result  = strcpy(ckalloc(strlen(errMsg)+1), errMsg);
            Tcl_ConditionNotify(&tpoolPtr->cond);
            Tcl_MutexUnlock(&startMutex);
            goto out;
        }
    }

    /*
................................................................................
            }
        } else if (tpoolPtr->tearDown) {
            PushWork(rPtr, tpoolPtr);
            break; /* Kill worker because pool is going down */
        }
        Tcl_MutexUnlock(&tpoolPtr->mutex);
        TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr);
        ckfree(rPtr->script);
        Tcl_MutexLock(&tpoolPtr->mutex);
        if (!rPtr->detached) {
            int new;
            Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone,
                                                 (void *)(size_t)rPtr->jobId, &new),
                             (ClientData)rPtr);
            SignalWaiter(tpoolPtr);
        } else {
            ckfree((char*)rPtr);
        }
    }

    /*
     * Tear down the worker
     */

    if (tpoolPtr->exitScript) {
        TpoolEval(interp, tpoolPtr->exitScript, TCL_STRLEN, NULL);
    }

    tpoolPtr->numWorkers--;
    SignalWaiter(tpoolPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

 out:
................................................................................
 *
 *----------------------------------------------------------------------
 */
static int
TpoolEval(interp, script, scriptLen, rPtr)
    Tcl_Interp *interp;
    char *script;
    STRLEN_TYPE scriptLen;
    TpoolResult *rPtr;
{
    int ret;
    size_t reslen;
    const char *result;
    const char *errorCode, *errorInfo;

................................................................................
        return ret;
    }
    rPtr->retcode = ret;
    if (ret == TCL_ERROR) {
        errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
        errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        if (errorCode != NULL) {
            rPtr->errorCode = ckalloc(1 + strlen(errorCode));
            strcpy(rPtr->errorCode, errorCode);
        }
        if (errorInfo != NULL) {
            rPtr->errorInfo = ckalloc(1 + strlen(errorInfo));
            strcpy(rPtr->errorInfo, errorInfo);
        }
    }

    result = Tcl_GetString(Tcl_GetObjResult(interp));
    reslen = Tcl_GetObjResult(interp)->length;

    if (reslen == 0) {
        rPtr->result = threadEmptyResult;
    } else {
        rPtr->result = strcpy(ckalloc(1 + reslen), result);
    }

    return ret;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
SetResult(interp, rPtr)
    Tcl_Interp *interp;
    TpoolResult *rPtr;
{
    if (rPtr->retcode == TCL_ERROR) {
        if (rPtr->errorCode) {
            if (interp) {
                Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_STRLEN));
            }
            ckfree(rPtr->errorCode);
            rPtr->errorCode = NULL;
        }
        if (rPtr->errorInfo) {
            if (interp) {
            	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(rPtr->errorInfo, TCL_STRLEN));
            }
            ckfree(rPtr->errorInfo);
            rPtr->errorInfo = NULL;
        }
    }
    if (rPtr->result) {
        if (rPtr->result == threadEmptyResult) {
            if (interp) {
                Tcl_ResetResult(interp);
            }
        } else {
            if (interp) {
                Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_STRLEN));
            }
            ckfree(rPtr->result);
            rPtr->result = NULL;
        }
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    /*
     * Tear down the pool structure
     */

    if (tpoolPtr->initScript) {
        ckfree(tpoolPtr->initScript);
    }
    if (tpoolPtr->exitScript) {
        ckfree(tpoolPtr->exitScript);
    }

    /*
     * Cleanup completed but not collected jobs
     */

    hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search);
    while (hPtr != NULL) {
        rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr);
        if (rPtr->result && rPtr->result != threadEmptyResult) {
            ckfree(rPtr->result);
        }
        if (rPtr->retcode == TCL_ERROR) {
            if (rPtr->errorInfo) {
                ckfree(rPtr->errorInfo);
            }
            if (rPtr->errorCode) {
                ckfree(rPtr->errorCode);
            }
        }
        ckfree((char*)rPtr);
        Tcl_DeleteHashEntry(hPtr);
        hPtr = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(&tpoolPtr->jobsDone);

    /*
     * Cleanup jobs posted but never completed.
     */

    for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) {
        ckfree(rPtr->script);
        ckfree((char*)rPtr);
    }
    Tcl_MutexFinalize(&tpoolPtr->mutex);
    Tcl_ConditionFinalize(&tpoolPtr->cond);
    ckfree((char*)tpoolPtr);

    return 0;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Tcl_Event *evPtr;

    waitPtr = PopWaiter(tpoolPtr);
    if (waitPtr == NULL) {
        return;
    }

    evPtr = (Tcl_Event*)ckalloc(sizeof(Tcl_Event));
    evPtr->proc = RunStopEvent;

    Tcl_ThreadQueueEvent(waitPtr->threadId,(Tcl_Event*)evPtr,TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(waitPtr->threadId);
}
 
/*
................................................................................
 */
static void
InitWaiter ()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->waitPtr == NULL) {
        tsdPtr->waitPtr = (TpoolWaiter*)ckalloc(sizeof(TpoolWaiter));
        tsdPtr->waitPtr->prevPtr  = NULL;
        tsdPtr->waitPtr->nextPtr  = NULL;
        tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread();
        Tcl_CreateThreadExitHandler(ThrExitHandler, (ClientData)tsdPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThrExitHandler --
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
ThrExitHandler(clientData)
    ClientData clientData;
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;

    ckfree((char*)tsdPtr->waitPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * AppExitHandler
 *
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
AppExitHandler(clientData)
    ClientData clientData;
{
    ThreadPool *tpoolPtr;

    Tcl_MutexLock(&listMutex);
    /*
     * Restart with head of list each time until empty. [Bug 1427570]
     */
................................................................................
    TCL_CMD(interp, TPOOL_CMD_PREFIX"release",  TpoolReleaseObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"suspend",  TpoolSuspendObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"resume",   TpoolResumeObjCmd);

    if (initialized == 0) {
        Tcl_MutexLock(&listMutex);
        if (initialized == 0) {
            Tcl_CreateExitHandler(AppExitHandler, (ClientData)-1);
            initialized = 1;
        }
        Tcl_MutexUnlock(&listMutex);
    }
    return TCL_OK;
}







|







 







|







 







|











|


|







 







|

|







 







|


|







 







|







 







|







 







|

|







 







|







|







 







|

|



|







 







|

|



|







 







|
|







 







|

|







 







|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|









|







 







|

|







 







|

|







 







|










|



|







 







|





|


|








|







 







|







 







|



|










|







 







|

|




|

|










|

|







 







|


|










|



|


|


|










|
|



|







 







|







 







|



|







 







|

|

|







 







|







 







|







58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
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
...
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
...
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
...
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
...
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
...
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
...
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
...
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
...
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
...
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
...
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
...
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
...
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
....
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
....
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
....
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
....
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
....
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
....
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
....
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
....
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
....
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
....
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
....
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
....
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
....
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
....
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
 * Structure for passing evaluation results
 */

typedef struct TpoolResult {
    int detached;                   /* Result is to be ignored */
    Tcl_WideInt jobId;              /* The job id of the current job */
    char *script;                   /* Script to evaluate in worker thread */
    size_t scriptLen;               /* Length of the script */
    int retcode;                    /* Tcl return code of the current job */
    char *result;                   /* Tcl result of the current job */
    char *errorCode;                /* On error: content of the errorCode */
    char *errorInfo;                /* On error: content of the errorInfo */
    Tcl_ThreadId threadId;          /* Originating thread id */
    ThreadPool *tpoolPtr;           /* Current thread pool */
    struct TpoolResult *nextPtr;
................................................................................
 * Miscelaneous functions used within this file
 */

static int
CreateWorker(Tcl_Interp *interp, ThreadPool *tpoolPtr);

static Tcl_ThreadCreateType
TpoolWorker(void *clientData);

static int
RunStopEvent(Tcl_Event *evPtr, int mask);

static void
PushWork(TpoolResult *rPtr, ThreadPool *tpoolPtr);

................................................................................
static TpoolWaiter*
PopWaiter(ThreadPool *tpoolPtr);

static void
SignalWaiter(ThreadPool *tpoolPtr);

static int
TpoolEval(Tcl_Interp *interp, char *script, size_t scriptLen,
                            TpoolResult *rPtr);
static void
SetResult(Tcl_Interp *interp, TpoolResult *rPtr);

static ThreadPool*
GetTpool(const char *tpoolName);

static ThreadPool*
GetTpoolUnl(const char *tpoolName);

static void
ThrExitHandler(void *clientData);

static void
AppExitHandler(void *clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static int
TpoolRelease(ThreadPool *tpoolPtr);

................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolCreateObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, minw, maxw, idle;
    char buf[64], *exs = NULL, *cmd = NULL;
    ThreadPool *tpoolPtr;

    /*
................................................................................
            }
        } else if (OPT_CMP(opt, "-idletime")) {
            if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) {
                return TCL_ERROR;
            }
        } else if (OPT_CMP(opt, "-initcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            cmd  = strcpy(Tcl_Alloc(objv[ii+1]->length+1), val);
        } else if (OPT_CMP(opt, "-exitcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            exs  = strcpy(Tcl_Alloc(objv[ii+1]->length+1), val);
        } else {
            goto usage;
        }
    }

    /*
     * Do some consistency checking
................................................................................
        maxw = minw;
    }

    /*
     * Allocate and initialize thread pool structure
     */

    tpoolPtr = Tcl_Alloc(sizeof(ThreadPool));
    memset(tpoolPtr, 0, sizeof(ThreadPool));

    tpoolPtr->minWorkers  = minw;
    tpoolPtr->maxWorkers  = maxw;
    tpoolPtr->idleTime    = idle;
    tpoolPtr->initScript  = cmd;
    tpoolPtr->exitScript  = exs;
................................................................................
            Tcl_MutexUnlock(&listMutex);
            return TCL_ERROR;
        }
    }
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));

    return TCL_OK;

 usage:
    Tcl_WrongNumArgs(interp, 1, objv,
                     "?-minworkers count? ?-maxworkers count? "
                     "?-initcmd script? ?-exitcmd script? "
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolPostObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_WideInt jobId = 0;
    int ii, detached = 0, nowait = 0;
    size_t len;
    const char *tpoolName, *script;
    TpoolResult *rPtr;
................................................................................
        }
    }

    /*
     * Create new job ticket and put it on the list.
     */

    rPtr = Tcl_Alloc(sizeof(TpoolResult));
    memset(rPtr, 0, sizeof(TpoolResult));

    if (detached == 0) {
        jobId = ++tpoolPtr->jobId;
        rPtr->jobId = jobId;
    }

    rPtr->script    = strcpy(Tcl_Alloc(len+1), script);
    rPtr->scriptLen = len;
    rPtr->detached  = detached;
    rPtr->threadId  = Tcl_GetCurrentThread();

    PushWork(rPtr, tpoolPtr);
    Tcl_ConditionNotify(&tpoolPtr->cond);
    Tcl_MutexUnlock(&tpoolPtr->mutex);
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolWaitObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, done;
    int wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *waitList, *doneList, **wObjv;
    ThreadPool *tpoolPtr;
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolCancelObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii;
    int wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *doneList, *waitList, **wObjv;
    ThreadPool *tpoolPtr;
    TpoolResult *rPtr;

................................................................................
                }
                if (rPtr->nextPtr != NULL) {
                    rPtr->nextPtr->prevPtr = rPtr->prevPtr;
                } else {
                    tpoolPtr->workTail = rPtr->prevPtr;
                }
                SetResult(NULL, rPtr); /* Just to free the result */
                Tcl_Free(rPtr->script);
                Tcl_Free(rPtr);
                Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]);
                break;
            }
        }
        if (rPtr == NULL && listVar) {
            Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]);
        }
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolGetObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *resVar = NULL;
    ThreadPool *tpoolPtr;
................................................................................
    }

    Tcl_DeleteHashEntry(hPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    ret = rPtr->retcode;
    SetResult(interp, rPtr);
    Tcl_Free(rPtr);

    if (resVar) {
        Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0);
        Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
        ret = TCL_OK;
    }

................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReserveObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReleaseObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolSuspendObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::suspend tpoolId
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolResumeObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::resume tpoolId
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolNamesObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    ThreadPool *tpoolPtr;
    Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);

    Tcl_MutexLock(&listMutex);
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) {
        char buf[32];
        sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
        Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));
    }
    Tcl_MutexUnlock(&listMutex);
    Tcl_SetObjResult(interp, listObj);

    return TCL_OK;
}
 
................................................................................

    /*
     * Create new worker thread here. Wait for the thread to start
     * because it's using the ThreadResult arg which is on our stack.
     */

    Tcl_MutexLock(&startMutex);
    if (Tcl_CreateThread(&id, TpoolWorker, &result,
                         TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_AUTO_LENGTH));
        Tcl_MutexUnlock(&startMutex);
        return TCL_ERROR;
    }
    while(result.retcode == -1) {
        Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL);
    }
    Tcl_MutexUnlock(&startMutex);
................................................................................
 *  None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_ThreadCreateType
TpoolWorker(clientData)
    void *clientData;
{
    TpoolResult          *rPtr = clientData;
    ThreadPool       *tpoolPtr = rPtr->tpoolPtr;

    int tout = 0;
    Tcl_Interp *interp;
    Tcl_Time waitTime, *idlePtr;
    const char *errMsg;

................................................................................
    } else {
        rPtr->retcode = 0;
    }
#endif

    if (rPtr->retcode == 1) {
        errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
        rPtr->result = strcpy(Tcl_Alloc(strlen(errMsg)+1), errMsg);
        Tcl_ConditionNotify(&tpoolPtr->cond);
        Tcl_MutexUnlock(&startMutex);
        goto out;
    }

    /*
     * Initialize the interpreter
     */

    if (tpoolPtr->initScript) {
        TpoolEval(interp, tpoolPtr->initScript, TCL_AUTO_LENGTH, rPtr);
        if (rPtr->retcode != TCL_OK) {
            rPtr->retcode = 1;
            errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
            rPtr->result  = strcpy(Tcl_Alloc(strlen(errMsg)+1), errMsg);
            Tcl_ConditionNotify(&tpoolPtr->cond);
            Tcl_MutexUnlock(&startMutex);
            goto out;
        }
    }

    /*
................................................................................
            }
        } else if (tpoolPtr->tearDown) {
            PushWork(rPtr, tpoolPtr);
            break; /* Kill worker because pool is going down */
        }
        Tcl_MutexUnlock(&tpoolPtr->mutex);
        TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr);
        Tcl_Free(rPtr->script);
        Tcl_MutexLock(&tpoolPtr->mutex);
        if (!rPtr->detached) {
            int new;
            Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone,
                                                 (void *)(size_t)rPtr->jobId, &new),
                             rPtr);
            SignalWaiter(tpoolPtr);
        } else {
            Tcl_Free(rPtr);
        }
    }

    /*
     * Tear down the worker
     */

    if (tpoolPtr->exitScript) {
        TpoolEval(interp, tpoolPtr->exitScript, TCL_AUTO_LENGTH, NULL);
    }

    tpoolPtr->numWorkers--;
    SignalWaiter(tpoolPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

 out:
................................................................................
 *
 *----------------------------------------------------------------------
 */
static int
TpoolEval(interp, script, scriptLen, rPtr)
    Tcl_Interp *interp;
    char *script;
    size_t scriptLen;
    TpoolResult *rPtr;
{
    int ret;
    size_t reslen;
    const char *result;
    const char *errorCode, *errorInfo;

................................................................................
        return ret;
    }
    rPtr->retcode = ret;
    if (ret == TCL_ERROR) {
        errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
        errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        if (errorCode != NULL) {
            rPtr->errorCode = Tcl_Alloc(1 + strlen(errorCode));
            strcpy(rPtr->errorCode, errorCode);
        }
        if (errorInfo != NULL) {
            rPtr->errorInfo = Tcl_Alloc(1 + strlen(errorInfo));
            strcpy(rPtr->errorInfo, errorInfo);
        }
    }

    result = Tcl_GetString(Tcl_GetObjResult(interp));
    reslen = Tcl_GetObjResult(interp)->length;

    if (reslen == 0) {
        rPtr->result = threadEmptyResult;
    } else {
        rPtr->result = strcpy(Tcl_Alloc(1 + reslen), result);
    }

    return ret;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
SetResult(interp, rPtr)
    Tcl_Interp *interp;
    TpoolResult *rPtr;
{
    if (rPtr->retcode == TCL_ERROR) {
        if (rPtr->errorCode) {
            if (interp) {
                Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_AUTO_LENGTH));
            }
            Tcl_Free(rPtr->errorCode);
            rPtr->errorCode = NULL;
        }
        if (rPtr->errorInfo) {
            if (interp) {
            	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(rPtr->errorInfo, TCL_AUTO_LENGTH));
            }
            Tcl_Free(rPtr->errorInfo);
            rPtr->errorInfo = NULL;
        }
    }
    if (rPtr->result) {
        if (rPtr->result == threadEmptyResult) {
            if (interp) {
                Tcl_ResetResult(interp);
            }
        } else {
            if (interp) {
                Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_AUTO_LENGTH));
            }
            Tcl_Free(rPtr->result);
            rPtr->result = NULL;
        }
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    /*
     * Tear down the pool structure
     */

    if (tpoolPtr->initScript) {
        Tcl_Free(tpoolPtr->initScript);
    }
    if (tpoolPtr->exitScript) {
        Tcl_Free(tpoolPtr->exitScript);
    }

    /*
     * Cleanup completed but not collected jobs
     */

    hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search);
    while (hPtr != NULL) {
        rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr);
        if (rPtr->result && rPtr->result != threadEmptyResult) {
            Tcl_Free(rPtr->result);
        }
        if (rPtr->retcode == TCL_ERROR) {
            if (rPtr->errorInfo) {
                Tcl_Free(rPtr->errorInfo);
            }
            if (rPtr->errorCode) {
                Tcl_Free(rPtr->errorCode);
            }
        }
        Tcl_Free(rPtr);
        Tcl_DeleteHashEntry(hPtr);
        hPtr = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(&tpoolPtr->jobsDone);

    /*
     * Cleanup jobs posted but never completed.
     */

    for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) {
        Tcl_Free(rPtr->script);
        Tcl_Free(rPtr);
    }
    Tcl_MutexFinalize(&tpoolPtr->mutex);
    Tcl_ConditionFinalize(&tpoolPtr->cond);
    Tcl_Free(tpoolPtr);

    return 0;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Tcl_Event *evPtr;

    waitPtr = PopWaiter(tpoolPtr);
    if (waitPtr == NULL) {
        return;
    }

    evPtr = Tcl_Alloc(sizeof(Tcl_Event));
    evPtr->proc = RunStopEvent;

    Tcl_ThreadQueueEvent(waitPtr->threadId,(Tcl_Event*)evPtr,TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(waitPtr->threadId);
}
 
/*
................................................................................
 */
static void
InitWaiter ()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->waitPtr == NULL) {
        tsdPtr->waitPtr = Tcl_Alloc(sizeof(TpoolWaiter));
        tsdPtr->waitPtr->prevPtr  = NULL;
        tsdPtr->waitPtr->nextPtr  = NULL;
        tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread();
        Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * ThrExitHandler --
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
ThrExitHandler(clientData)
    void *clientData;
{
    ThreadSpecificData *tsdPtr = clientData;

    Tcl_Free(tsdPtr->waitPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * AppExitHandler
 *
................................................................................
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
AppExitHandler(clientData)
    void *clientData;
{
    ThreadPool *tpoolPtr;

    Tcl_MutexLock(&listMutex);
    /*
     * Restart with head of list each time until empty. [Bug 1427570]
     */
................................................................................
    TCL_CMD(interp, TPOOL_CMD_PREFIX"release",  TpoolReleaseObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"suspend",  TpoolSuspendObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"resume",   TpoolResumeObjCmd);

    if (initialized == 0) {
        Tcl_MutexLock(&listMutex);
        if (initialized == 0) {
            Tcl_CreateExitHandler(AppExitHandler, (void *)-1);
            initialized = 1;
        }
        Tcl_MutexUnlock(&listMutex);
    }
    return TCL_OK;
}

Changes to generic/threadSpCmd.c.

173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
...
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
...
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
...
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
....
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
....
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
....
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
....
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
....
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
....
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
....
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
....
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
....
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadMutexObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    char type;
    SpMutex *mutexPtr;
................................................................................
            }
        }

        /*
         * Create the requested mutex
         */

        mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
        mutexPtr->type   = type;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        /*
         * Generate Tcl name for this mutex
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadRWMutexObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    SpMutex *mutexPtr;
    Sp_ReadWriteMutex *rwPtr;
................................................................................

    if (opt == (int)w_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
        mutexPtr->type   = WMUTEXID;
        mutexPtr->refcnt = 0;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCondObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret, timeMsec = 0;
    size_t nameLen;
    const char *condvName, *mutexName;
    SpMutex *mutexPtr;
    SpCondv *condvPtr;
................................................................................

    if (opt == (int)c_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        condvPtr = (SpCondv*)ckalloc(sizeof(SpCondv));
        condvPtr->refcnt = 0;
        condvPtr->bucket = NULL;
        condvPtr->hentry = NULL;
        condvPtr->mutex  = NULL;
        condvPtr->cond   = NULL; /* Will be auto-initialized */

        nameObj = GetName(CONDVID, (void*)condvPtr);
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadEvalObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, optx, internal;
    const char *mutexName;
    Tcl_Obj *scriptObj;
    SpMutex *mutexPtr = NULL;
    static Sp_RecursiveMutex evalMutex;
................................................................................
    Tcl_DecrRefCount(scriptObj);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_STRLEN));
    }

    /*
     * Unlock the mutex.
     */

    if (internal) {
................................................................................
    int new;
    SpBucket *bucketPtr = GetBucket(type, handle, len);
    Tcl_HashEntry *hashEntryPtr;

    Tcl_MutexLock(&bucketPtr->lock);

    hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &new);
    Tcl_SetHashValue(hashEntryPtr, (ClientData)itemPtr);

    itemPtr->refcnt = 0;
    itemPtr->bucket = bucketPtr;
    itemPtr->hentry = hashEntryPtr;

    Tcl_MutexUnlock(&bucketPtr->lock);
}
................................................................................
    }
    if (!SpMutexFinalize(mutexPtr)) {
        PutMutex(mutexPtr);
        return 0;
    }
    PutMutex(mutexPtr);
    RemoveAnyItem(SP_MUTEX, name, len);
    ckfree((char*)mutexPtr);

    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    }
    if (!SpCondvFinalize(condvPtr)) {
        PutCondv(condvPtr);
        return 0;
    }
    PutCondv(condvPtr);
    RemoveAnyItem(SP_CONDV, name, len);
    ckfree((char*)condvPtr);

    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Sp_ExclusiveMutex_ *emPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
            *muxPtr = (Sp_ExclusiveMutex_*)
                ckalloc(sizeof(Sp_ExclusiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    /*
     * Try locking if not currently locked by anybody.
................................................................................
        Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
        if (emPtr->lock) {
            Tcl_MutexFinalize(&emPtr->lock);
        }
        if (emPtr->mutex) {
            Tcl_MutexFinalize(&emPtr->mutex);
        }
        ckfree((char*)*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexLock --
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_RecursiveMutex_*)0) {
            *muxPtr = (Sp_RecursiveMutex_*)
                ckalloc(sizeof(Sp_RecursiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
    Tcl_MutexLock(&rmPtr->lock);
................................................................................
        Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
        if (rmPtr->lock) {
            Tcl_MutexFinalize(&rmPtr->lock);
        }
        if (rmPtr->cond) {
            Tcl_ConditionFinalize(&rmPtr->cond);
        }
        ckfree((char*)*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexRLock --
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr = (Sp_ReadWriteMutex_*)
                ckalloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr = (Sp_ReadWriteMutex_*)
                ckalloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
................................................................................
        }
        if (rwPtr->rcond) {
            Tcl_ConditionFinalize(&rwPtr->rcond);
        }
        if (rwPtr->wcond) {
            Tcl_ConditionFinalize(&rwPtr->wcond);
        }
        ckfree((char*)*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * AnyMutexIsLocked --






|

|







 







|







 







|

|







 







|







 







|

|







 







|







 







|

|







 







|







 







|







 







|







 







|







 







|

|
<
|







 







|







 







|
|







 







|







 







|
|







 







|
|







 







|







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
...
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
...
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
...
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
...
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
....
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
....
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
....
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365

1366
1367
1368
1369
1370
1371
1372
1373
....
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
....
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
....
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
....
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
....
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
....
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadMutexObjCmd(dummy, interp, objc, objv)
    void *dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    char type;
    SpMutex *mutexPtr;
................................................................................
            }
        }

        /*
         * Create the requested mutex
         */

        mutexPtr = Tcl_Alloc(sizeof(SpMutex));
        mutexPtr->type   = type;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        /*
         * Generate Tcl name for this mutex
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadRWMutexObjCmd(dummy, interp, objc, objv)
    void *dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    SpMutex *mutexPtr;
    Sp_ReadWriteMutex *rwPtr;
................................................................................

    if (opt == (int)w_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        mutexPtr = Tcl_Alloc(sizeof(SpMutex));
        mutexPtr->type   = WMUTEXID;
        mutexPtr->refcnt = 0;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCondObjCmd(dummy, interp, objc, objv)
    void *dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int opt, ret, timeMsec = 0;
    size_t nameLen;
    const char *condvName, *mutexName;
    SpMutex *mutexPtr;
    SpCondv *condvPtr;
................................................................................

    if (opt == (int)c_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        condvPtr = Tcl_Alloc(sizeof(SpCondv));
        condvPtr->refcnt = 0;
        condvPtr->bucket = NULL;
        condvPtr->hentry = NULL;
        condvPtr->mutex  = NULL;
        condvPtr->cond   = NULL; /* Will be auto-initialized */

        nameObj = GetName(CONDVID, (void*)condvPtr);
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadEvalObjCmd(dummy, interp, objc, objv)
    void *dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, optx, internal;
    const char *mutexName;
    Tcl_Obj *scriptObj;
    SpMutex *mutexPtr = NULL;
    static Sp_RecursiveMutex evalMutex;
................................................................................
    Tcl_DecrRefCount(scriptObj);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_AUTO_LENGTH));
    }

    /*
     * Unlock the mutex.
     */

    if (internal) {
................................................................................
    int new;
    SpBucket *bucketPtr = GetBucket(type, handle, len);
    Tcl_HashEntry *hashEntryPtr;

    Tcl_MutexLock(&bucketPtr->lock);

    hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &new);
    Tcl_SetHashValue(hashEntryPtr, itemPtr);

    itemPtr->refcnt = 0;
    itemPtr->bucket = bucketPtr;
    itemPtr->hentry = hashEntryPtr;

    Tcl_MutexUnlock(&bucketPtr->lock);
}
................................................................................
    }
    if (!SpMutexFinalize(mutexPtr)) {
        PutMutex(mutexPtr);
        return 0;
    }
    PutMutex(mutexPtr);
    RemoveAnyItem(SP_MUTEX, name, len);
    Tcl_Free(mutexPtr);

    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    }
    if (!SpCondvFinalize(condvPtr)) {
        PutCondv(condvPtr);
        return 0;
    }
    PutCondv(condvPtr);
    RemoveAnyItem(SP_CONDV, name, len);
    Tcl_Free(condvPtr);

    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    Sp_ExclusiveMutex_ *emPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == NULL) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == NULL) {

            *muxPtr = Tcl_Alloc(sizeof(Sp_ExclusiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    /*
     * Try locking if not currently locked by anybody.
................................................................................
        Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
        if (emPtr->lock) {
            Tcl_MutexFinalize(&emPtr->lock);
        }
        if (emPtr->mutex) {
            Tcl_MutexFinalize(&emPtr->mutex);
        }
        Tcl_Free(*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexLock --
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_RecursiveMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_RecursiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
    Tcl_MutexLock(&rmPtr->lock);
................................................................................
        Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
        if (rmPtr->lock) {
            Tcl_MutexFinalize(&rmPtr->lock);
        }
        if (rmPtr->cond) {
            Tcl_ConditionFinalize(&rmPtr->cond);
        }
        Tcl_Free(*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexRLock --
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
................................................................................
    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;
    Tcl_MutexLock(&rwPtr->lock);
................................................................................
        }
        if (rwPtr->rcond) {
            Tcl_ConditionFinalize(&rwPtr->rcond);
        }
        if (rwPtr->wcond) {
            Tcl_ConditionFinalize(&rwPtr->wcond);
        }
        Tcl_Free(*muxPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * AnyMutexIsLocked --

Changes to generic/threadSvCmd.c.

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
...
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
...
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
...
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
...
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
...
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
...
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
...
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
...
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
....
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
....
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
....
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
....
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
....
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
....
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
....
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
....
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
....
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
....
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
....
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
....
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
....
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
....
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
....
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
....
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
....
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
....
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
....
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
....
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
....
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
....
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
....
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
....
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
....
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
....
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
static int DeleteArray(Tcl_Interp *, Array*);

static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);

#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
static void SvFinalize(ClientData);
#endif /* SV_FINALIZE */

static PsStore* GetPsStore(const char *handle);

static int SvObjDispatchObjCmd(ClientData arg,
            Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 
/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterCommand --
 *
................................................................................
                   const char *cmdName,                /* Name of command to register */
                   Tcl_ObjCmdProc *objProc,            /* Object-based command procedure */
                   Tcl_CmdDeleteProc *delProc,         /* Command delete procedure */
                   int aolSpecial)
{
    int len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
    int len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
    SvCmdInfo *newCmd = (SvCmdInfo*)ckalloc(sizeof(SvCmdInfo) + len + len2);

    /*
     * Setup new command structure
     */

    newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));
    newCmd->cmdName2 = newCmd->cmdName + len;
................................................................................
 */

void
Sv_RegisterObjType(
                   const Tcl_ObjType *typePtr,               /* Type of object to register */
                   Tcl_DupInternalRepProc *dupProc)    /* Custom object duplicator */
{
    RegType *newType = (RegType*)ckalloc(sizeof(RegType));

    /*
     * Setup new type structure
     */

    newType->typePtr = typePtr;
    newType->dupIntRepProc = dupProc;
................................................................................
 *-----------------------------------------------------------------------------
 */

void
Sv_RegisterPsStore(const PsStore *psStorePtr)
{

    PsStore *psPtr = (PsStore*)ckalloc(sizeof(PsStore));

    *psPtr = *psStorePtr;

    /*
     * Plug-in in shared list
     */

................................................................................
            return TCL_BREAK;
        }
    } else {
        Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles);
        LOCK_CONTAINER(*retObj);
        if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) {
            UNLOCK_CONTAINER(*retObj);
            Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_STRLEN));
            return TCL_BREAK;
        }
        *offset = 2; /* Consumed two arguments: object, cmd */
    }

    return TCL_OK;
}
................................................................................
 *
 * Results:
 *      Pointer to the newly allocated persistent storage handler. Caller
 *      must free this block when done with it. If none found, returns NULL,
 *
 * Side effects;
 *      Memory gets allocated. Caller should free the return value of this
 *      function using ckfree().
 *
 *-----------------------------------------------------------------------------
 */

static PsStore*
GetPsStore(const char *handle)
{
................................................................................
     */

    Tcl_MutexLock(&svMutex);
    for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
        if (strcmp(tmpPtr->type, type) == 0) {
            tmpPtr->psHandle = tmpPtr->psOpen(addr);
            if (tmpPtr->psHandle) {
                psPtr = (PsStore*)ckalloc(sizeof(PsStore));
                *psPtr = *tmpPtr;
                psPtr->nextPtr = NULL;
            }
            break;
        }
    }
    Tcl_MutexUnlock(&svMutex);
................................................................................
    case SV_CHANGED:
        if (psPtr) {
            key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
            val = Tcl_GetString(svObj->tclObj);
            len = svObj->tclObj->length;
            if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_STRLEN));
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    return TCL_ERROR; /* Should never be reached */
................................................................................
    Tcl_HashEntry *hPtr;

    hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &new);
    if (!new) {
        return (Array*)Tcl_GetHashValue(hPtr);
    }

    arrayPtr = (Array*)ckalloc(sizeof(Array));
    arrayPtr->bucketPtr = bucketPtr;
    arrayPtr->entryPtr  = hPtr;
    arrayPtr->psPtr     = NULL;
    arrayPtr->bindAddr  = NULL;

    Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, arrayPtr);
................................................................................
 */

static int
UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
{
    PsStore *psPtr = arrayPtr->psPtr;
    if (arrayPtr->bindAddr) {
        ckfree(arrayPtr->bindAddr);
        arrayPtr->bindAddr = NULL;
    }
    if (psPtr) {
        if (psPtr->psClose(psPtr->psHandle) == -1) {
            if (interp) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
            }
            return TCL_ERROR;
        }
        ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
        arrayPtr->psPtr = NULL;
    }
    return TCL_OK;
}

static int
DeleteArray(Tcl_Interp *interp, Array *arrayPtr)
................................................................................
        };
    }
    if (arrayPtr->entryPtr) {
        Tcl_DeleteHashEntry(arrayPtr->entryPtr);
    }

    Tcl_DeleteHashTable(&arrayPtr->vars);
    ckfree((char*)arrayPtr);

    return TCL_OK;
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
    Container tmp[2];
    size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp);
    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
    char *basePtr;
    register Container *prevPtr = NULL, *objPtr = NULL;
    register int i;

    basePtr = (char*)ckalloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    objPtr = (Container*)basePtr;
    objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */

    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
        objPtr->nextPtr = prevPtr;
................................................................................
SvFinalizeContainers(Bucket *bucketPtr)
{
   Container *tmpPtr, *objPtr = bucketPtr->freeCt;

    while (objPtr) {
        if (objPtr->chunkAddr == (char*)objPtr) {
            tmpPtr = objPtr->nextPtr;
            ckfree((char*)objPtr);
            objPtr = tmpPtr;
        } else {
            objPtr = objPtr->nextPtr;
        }
    }
}
#endif /* SV_FINALIZE */
................................................................................
     * Handle the string rep
     */

    if (objPtr->bytes == NULL) {
        dupPtr->bytes = NULL;
    } else if (objPtr->bytes != Sv_tclEmptyStringRep) {
        /* A copy of TclInitStringRep macro */
        dupPtr->bytes = (char*)ckalloc((unsigned)objPtr->length + 1);
        if (objPtr->length > 0) {
            memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
                   (unsigned)objPtr->length);
        }
        dupPtr->length = objPtr->length;
        dupPtr->bytes[objPtr->length] = '\0';
    }
................................................................................
 *      Depends on the dispatched command
 *
 *-----------------------------------------------------------------------------
 */

static int
SvObjDispatchObjCmd(
                    ClientData arg,                     /* Pointer to object container. */
                    Tcl_Interp *interp,                 /* Current interpreter. */
                    int objc,                           /* Number of arguments. */
                    Tcl_Obj *const objv[])              /* Argument objects. */
{
    const char *cmdName;
    SvCmdInfo *cmdPtr;

................................................................................
 *      New Tcl command gets created.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvObjObjCmd(
            ClientData arg,                     /* != NULL if aolSpecial */
            Tcl_Interp *interp,                 /* Current interpreter. */
            STRLEN_TYPE objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int new, off, ret, flg;
    char buf[128];
    Tcl_Obj *val = NULL;
    Container *svObj = NULL;

................................................................................

    /*
     * Format the command name
     */

    sprintf(buf, "::%p", (int*)svObj);
    svObj->aolSpecial = (arg != NULL);
    Tcl_CreateObjCommand(interp, buf, (ClientData)SvObjDispatchObjCmd, (ClientData)svObj, NULL);
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_STRLEN));

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvArrayObjCmd(
              ClientData arg,                     /* Pointer to object container. */
              Tcl_Interp *interp,                 /* Current interpreter. */
              STRLEN_TYPE objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i, argx = 0, index, ret = TCL_OK;
    STRLEN_TYPE lobjc = 0;
    const char *arrayName = NULL;
    Array *arrayPtr = NULL;
    Tcl_Obj **lobjv = NULL;
    Container *svObj, *elObj = NULL;

    static const char *const opts[] = {
        "set",  "reset", "get", "names", "size", "exists", "isbound",
................................................................................
        }
        if (index == ARESET) {
            ret = FlushArray(arrayPtr);
            if (ret != TCL_OK) {
                if (arrayPtr->psPtr) {
                    PsStore *psPtr = arrayPtr->psPtr;
                    const char *err = psPtr->psError(psPtr->psHandle);
                    Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_STRLEN));
                }
                goto cmdExit;
            }
        }
        for (i = 0; i < lobjc; i += 2) {
            const char *key = Tcl_GetString(lobjv[i]);
            elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);
................................................................................
            Tcl_Obj *resObj = Tcl_NewListObj(0, NULL);
            const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]);
            Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            while (hPtr) {
                char *key = Tcl_GetHashKey(&arrayPtr->vars, hPtr);
                if (pattern == NULL || Tcl_StringMatch(key, pattern)) {
                    Tcl_ListObjAppendElement(interp, resObj,
                            Tcl_NewStringObj(key, TCL_STRLEN));
                    if (index == AGET) {
                        elObj = (Container*)Tcl_GetHashValue(hPtr);
                        Tcl_ListObjAppendElement(interp, resObj,
                                Sv_DuplicateObj(elObj->tclObj));
                    }
                }
                hPtr = Tcl_NextHashEntry(&search);
................................................................................
            ret = TCL_ERROR;
            goto cmdExit;
        }
        if (arrayPtr) {
            Tcl_HashSearch search;
            hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(ckalloc(len+1), psurl);
            while (hPtr) {
                svObj = Tcl_GetHashValue(hPtr);
                if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
                    ret = TCL_ERROR;
                    goto cmdExit;
                }
                hPtr = Tcl_NextHashEntry(&search);
            }
        } else {
            arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(ckalloc(len+1), psurl);
        }
        if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) {
            do {
                Tcl_Obj * tclObj = Tcl_NewStringObj(val, len);
                hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvUnsetObjCmd(
              ClientData dummy,                   /* Not used. */
              Tcl_Interp *interp,                 /* Current interpreter. */
              STRLEN_TYPE objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ii;
    const char *arrayName;
    Array *arrayPtr;

    if (objc < 2) {
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvNamesObjCmd(
              ClientData arg,                     /* != NULL if aolSpecial */
              Tcl_Interp *interp,                 /* Current interpreter. */
              STRLEN_TYPE objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i;
    const char *pattern = NULL;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_Obj *resObj;
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvGetObjCmd(
            ClientData arg,                     /* Pointer to object container. */
            Tcl_Interp *interp,                 /* Current interpreter. */
            STRLEN_TYPE objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret;
    Tcl_Obj *res;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvExistsObjCmd(
               ClientData arg,                     /* Pointer to object container. */
               Tcl_Interp *interp,                 /* Current interpreter. */
               STRLEN_TYPE objc,                   /* Number of arguments. */
               Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvSetObjCmd(
            ClientData arg,                     /* Pointer to object container */
            Tcl_Interp *interp,                 /* Current interpreter. */
            STRLEN_TYPE objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off, flg, mode;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvIncrObjCmd(
             ClientData arg,                     /* Pointer to object container */
             Tcl_Interp *interp,                 /* Current interpreter. */
             STRLEN_TYPE objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret, flg, new = 0;
    Tcl_WideInt incrValue = 1, currValue = 0;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvAppendObjCmd(
               ClientData arg,                     /* Pointer to object container */
               Tcl_Interp *interp,                 /* Current interpreter. */
               STRLEN_TYPE objc,                   /* Number of arguments. */
               Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i, off, flg, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvPopObjCmd(
            ClientData arg,                     /* Pointer to object container */
            Tcl_Interp *interp,                 /* Current interpreter. */
            STRLEN_TYPE objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off;
    Tcl_Obj *retObj;
    Array *arrayPtr = NULL;
    Container *svObj = (Container*)arg;

................................................................................
    retObj = svObj->tclObj;
    svObj->tclObj = NULL;

    if (DeleteContainer(svObj) != TCL_OK) {
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            const char *err = psPtr->psError(psPtr->psHandle);
            Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_STRLEN));
        }
        ret = TCL_ERROR;
        goto cmd_exit;
    }

    if ((objc - off) == 0) {
        Tcl_SetObjResult(interp, retObj);
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvMoveObjCmd(
             ClientData arg,                     /* Pointer to object container. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             STRLEN_TYPE objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off, new;
    const char *toKey;
    Tcl_HashEntry *hPtr;
    Container *svObj = (Container*)arg;

................................................................................
    }
    if (svObj->entryPtr) {
        char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_STRLEN));
                return TCL_ERROR;
            }
        }
        Tcl_DeleteHashEntry(svObj->entryPtr);
    }

    svObj->entryPtr = hPtr;
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
SvLockObjCmd(
             ClientData dummy,                   /* Not used. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             STRLEN_TYPE objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret;
    Tcl_Obj *scriptObj;
    Bucket *bucketPtr;
    Array *arrayPtr = NULL;

................................................................................
    ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_STRLEN));
    }

    /*
     * We unlock the bucket directly, w/o going to Sv_Unlock()
     * since it needs the array which may be unset by the script.
     */

................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
SvHandlersObjCmd(
             ClientData arg,                     /* Not used. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                           /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    PsStore *tmpPtr = NULL;

    /*
................................................................................

    /*
     * Plug-in registered commands in current interpreter
     */

    for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr,
                (ClientData)0, (Tcl_CmdDeleteProc*)0);
#ifdef NS_AOLSERVER
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr,
                (ClientData)(size_t)cmdPtr->aolSpecial, (Tcl_CmdDeleteProc*)0);
#endif
    }

    /*
     * Create array of buckets and initialize each bucket
     */

    if (buckets == NULL) {
        Tcl_MutexLock(&bucketsMutex);
        if (buckets == NULL) {
            buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS);

            for (i = 0; i < NUMBUCKETS; ++i) {
                bucketPtr = &buckets[i];
                memset(bucketPtr, 0, sizeof(Bucket));
                Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
                Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS);
            }
................................................................................
 * Side effects
 *    Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */

static void
SvFinalize (ClientData clientData)
{
    register int i;
    SvCmdInfo *cmdPtr;
    RegType *regPtr;

    Tcl_HashEntry *hashPtr;
    Tcl_HashSearch search;
................................................................................
                if (bucketPtr->lock) {
                    Sp_RecursiveMutexFinalize(&bucketPtr->lock);
                }
                SvFinalizeContainers(bucketPtr);
                Tcl_DeleteHashTable(&bucketPtr->handles);
                Tcl_DeleteHashTable(&bucketPtr->arrays);
            }
            ckfree((char *)buckets), buckets = NULL;
        }
        buckets = NULL;
        Tcl_MutexUnlock(&bucketsMutex);
    }

    Tcl_MutexLock(&svMutex);

................................................................................
     * Reclaim memory for registered commands
     */

    if (svCmdInfo != NULL) {
        cmdPtr = svCmdInfo;
        while (cmdPtr) {
            SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
            ckfree((char*)cmdPtr);
            cmdPtr = tmpPtr;
        }
        svCmdInfo = NULL;
    }

    /*
     * Reclaim memory for registered object types
     */

    if (regType != NULL) {
        regPtr = regType;
        while (regPtr) {
            RegType *tmpPtr = regPtr->nextPtr;
            ckfree((char*)regPtr);
            regPtr = tmpPtr;
        }
        regType = NULL;
    }

    Tcl_MutexUnlock(&svMutex);







|




|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|










|







 







|







 







|







 







|







 







|







 







|







 







|

|







 







|

|







 







|

|



|







 







|







 







|







 







|











|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|

|







 







|







 







|

|







 







|







 







|

|







 







|







 







|







 







|


|










|







 







|







 







|







 







|













|







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
...
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
...
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
...
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
...
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
...
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
...
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
...
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
...
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
...
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
....
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
....
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
....
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
....
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
....
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
....
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
....
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
....
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
....
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
....
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
....
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
....
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
....
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
....
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
....
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
....
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
....
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
....
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
....
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
....
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
....
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
....
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
....
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
....
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
....
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
....
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
static int DeleteArray(Tcl_Interp *, Array*);

static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);

#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
static void SvFinalize(void *);
#endif /* SV_FINALIZE */

static PsStore* GetPsStore(const char *handle);

static int SvObjDispatchObjCmd(void *arg,
            Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 
/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterCommand --
 *
................................................................................
                   const char *cmdName,                /* Name of command to register */
                   Tcl_ObjCmdProc *objProc,            /* Object-based command procedure */
                   Tcl_CmdDeleteProc *delProc,         /* Command delete procedure */
                   int aolSpecial)
{
    int len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
    int len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
    SvCmdInfo *newCmd = Tcl_Alloc(sizeof(SvCmdInfo) + len + len2);

    /*
     * Setup new command structure
     */

    newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));
    newCmd->cmdName2 = newCmd->cmdName + len;
................................................................................
 */

void
Sv_RegisterObjType(
                   const Tcl_ObjType *typePtr,               /* Type of object to register */
                   Tcl_DupInternalRepProc *dupProc)    /* Custom object duplicator */
{
    RegType *newType = Tcl_Alloc(sizeof(RegType));

    /*
     * Setup new type structure
     */

    newType->typePtr = typePtr;
    newType->dupIntRepProc = dupProc;
................................................................................
 *-----------------------------------------------------------------------------
 */

void
Sv_RegisterPsStore(const PsStore *psStorePtr)
{

    PsStore *psPtr = Tcl_Alloc(sizeof(PsStore));

    *psPtr = *psStorePtr;

    /*
     * Plug-in in shared list
     */

................................................................................
            return TCL_BREAK;
        }
    } else {
        Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles);
        LOCK_CONTAINER(*retObj);
        if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) {
            UNLOCK_CONTAINER(*retObj);
            Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_AUTO_LENGTH));
            return TCL_BREAK;
        }
        *offset = 2; /* Consumed two arguments: object, cmd */
    }

    return TCL_OK;
}
................................................................................
 *
 * Results:
 *      Pointer to the newly allocated persistent storage handler. Caller
 *      must free this block when done with it. If none found, returns NULL,
 *
 * Side effects;
 *      Memory gets allocated. Caller should free the return value of this
 *      function using Tcl_Free().
 *
 *-----------------------------------------------------------------------------
 */

static PsStore*
GetPsStore(const char *handle)
{
................................................................................
     */

    Tcl_MutexLock(&svMutex);
    for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
        if (strcmp(tmpPtr->type, type) == 0) {
            tmpPtr->psHandle = tmpPtr->psOpen(addr);
            if (tmpPtr->psHandle) {
                psPtr = Tcl_Alloc(sizeof(PsStore));
                *psPtr = *tmpPtr;
                psPtr->nextPtr = NULL;
            }
            break;
        }
    }
    Tcl_MutexUnlock(&svMutex);
................................................................................
    case SV_CHANGED:
        if (psPtr) {
            key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
            val = Tcl_GetString(svObj->tclObj);
            len = svObj->tclObj->length;
            if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    return TCL_ERROR; /* Should never be reached */
................................................................................
    Tcl_HashEntry *hPtr;

    hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &new);
    if (!new) {
        return (Array*)Tcl_GetHashValue(hPtr);
    }

    arrayPtr = Tcl_Alloc(sizeof(Array));
    arrayPtr->bucketPtr = bucketPtr;
    arrayPtr->entryPtr  = hPtr;
    arrayPtr->psPtr     = NULL;
    arrayPtr->bindAddr  = NULL;

    Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, arrayPtr);
................................................................................
 */

static int
UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
{
    PsStore *psPtr = arrayPtr->psPtr;
    if (arrayPtr->bindAddr) {
        Tcl_Free(arrayPtr->bindAddr);
        arrayPtr->bindAddr = NULL;
    }
    if (psPtr) {
        if (psPtr->psClose(psPtr->psHandle) == -1) {
            if (interp) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
            }
            return TCL_ERROR;
        }
        Tcl_Free(arrayPtr->psPtr), arrayPtr->psPtr = NULL;
        arrayPtr->psPtr = NULL;
    }
    return TCL_OK;
}

static int
DeleteArray(Tcl_Interp *interp, Array *arrayPtr)
................................................................................
        };
    }
    if (arrayPtr->entryPtr) {
        Tcl_DeleteHashEntry(arrayPtr->entryPtr);
    }

    Tcl_DeleteHashTable(&arrayPtr->vars);
    Tcl_Free(arrayPtr);

    return TCL_OK;
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
    Container tmp[2];
    size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp);
    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
    char *basePtr;
    register Container *prevPtr = NULL, *objPtr = NULL;
    register int i;

    basePtr = Tcl_Alloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    objPtr = (Container*)basePtr;
    objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */

    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
        objPtr->nextPtr = prevPtr;
................................................................................
SvFinalizeContainers(Bucket *bucketPtr)
{
   Container *tmpPtr, *objPtr = bucketPtr->freeCt;

    while (objPtr) {
        if (objPtr->chunkAddr == (char*)objPtr) {
            tmpPtr = objPtr->nextPtr;
            Tcl_Free(objPtr);
            objPtr = tmpPtr;
        } else {
            objPtr = objPtr->nextPtr;
        }
    }
}
#endif /* SV_FINALIZE */
................................................................................
     * Handle the string rep
     */

    if (objPtr->bytes == NULL) {
        dupPtr->bytes = NULL;
    } else if (objPtr->bytes != Sv_tclEmptyStringRep) {
        /* A copy of TclInitStringRep macro */
        dupPtr->bytes = Tcl_Alloc((unsigned)objPtr->length + 1);
        if (objPtr->length > 0) {
            memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
                   (unsigned)objPtr->length);
        }
        dupPtr->length = objPtr->length;
        dupPtr->bytes[objPtr->length] = '\0';
    }
................................................................................
 *      Depends on the dispatched command
 *
 *-----------------------------------------------------------------------------
 */

static int
SvObjDispatchObjCmd(
                    void *arg,                     /* Pointer to object container. */
                    Tcl_Interp *interp,                 /* Current interpreter. */
                    int objc,                           /* Number of arguments. */
                    Tcl_Obj *const objv[])              /* Argument objects. */
{
    const char *cmdName;
    SvCmdInfo *cmdPtr;

................................................................................
 *      New Tcl command gets created.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvObjObjCmd(
            void *arg,                     /* != NULL if aolSpecial */
            Tcl_Interp *interp,                 /* Current interpreter. */
            int objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int new, off, ret, flg;
    char buf[128];
    Tcl_Obj *val = NULL;
    Container *svObj = NULL;

................................................................................

    /*
     * Format the command name
     */

    sprintf(buf, "::%p", (int*)svObj);
    svObj->aolSpecial = (arg != NULL);
    Tcl_CreateObjCommand(interp, buf, SvObjDispatchObjCmd, svObj, NULL);
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvArrayObjCmd(
              void *arg,                     /* Pointer to object container. */
              Tcl_Interp *interp,                 /* Current interpreter. */
              int objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i, argx = 0, index, ret = TCL_OK;
    int lobjc = 0;
    const char *arrayName = NULL;
    Array *arrayPtr = NULL;
    Tcl_Obj **lobjv = NULL;
    Container *svObj, *elObj = NULL;

    static const char *const opts[] = {
        "set",  "reset", "get", "names", "size", "exists", "isbound",
................................................................................
        }
        if (index == ARESET) {
            ret = FlushArray(arrayPtr);
            if (ret != TCL_OK) {
                if (arrayPtr->psPtr) {
                    PsStore *psPtr = arrayPtr->psPtr;
                    const char *err = psPtr->psError(psPtr->psHandle);
                    Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
                }
                goto cmdExit;
            }
        }
        for (i = 0; i < lobjc; i += 2) {
            const char *key = Tcl_GetString(lobjv[i]);
            elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);
................................................................................
            Tcl_Obj *resObj = Tcl_NewListObj(0, NULL);
            const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]);
            Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            while (hPtr) {
                char *key = Tcl_GetHashKey(&arrayPtr->vars, hPtr);
                if (pattern == NULL || Tcl_StringMatch(key, pattern)) {
                    Tcl_ListObjAppendElement(interp, resObj,
                            Tcl_NewStringObj(key, TCL_AUTO_LENGTH));
                    if (index == AGET) {
                        elObj = (Container*)Tcl_GetHashValue(hPtr);
                        Tcl_ListObjAppendElement(interp, resObj,
                                Sv_DuplicateObj(elObj->tclObj));
                    }
                }
                hPtr = Tcl_NextHashEntry(&search);
................................................................................
            ret = TCL_ERROR;
            goto cmdExit;
        }
        if (arrayPtr) {
            Tcl_HashSearch search;
            hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
            while (hPtr) {
                svObj = Tcl_GetHashValue(hPtr);
                if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
                    ret = TCL_ERROR;
                    goto cmdExit;
                }
                hPtr = Tcl_NextHashEntry(&search);
            }
        } else {
            arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
        }
        if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) {
            do {
                Tcl_Obj * tclObj = Tcl_NewStringObj(val, len);
                hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvUnsetObjCmd(
              void *dummy,                   /* Not used. */
              Tcl_Interp *interp,                 /* Current interpreter. */
              int objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ii;
    const char *arrayName;
    Array *arrayPtr;

    if (objc < 2) {
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvNamesObjCmd(
              void *arg,                     /* != NULL if aolSpecial */
              Tcl_Interp *interp,                 /* Current interpreter. */
              int objc,                   /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i;
    const char *pattern = NULL;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_Obj *resObj;
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvGetObjCmd(
            void *arg,                     /* Pointer to object container. */
            Tcl_Interp *interp,                 /* Current interpreter. */
            int objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret;
    Tcl_Obj *res;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvExistsObjCmd(
               void *arg,                     /* Pointer to object container. */
               Tcl_Interp *interp,                 /* Current interpreter. */
               int objc,                   /* Number of arguments. */
               Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvSetObjCmd(
            void *arg,                     /* Pointer to object container */
            Tcl_Interp *interp,                 /* Current interpreter. */
            int objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off, flg, mode;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvIncrObjCmd(
             void *arg,                     /* Pointer to object container */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret, flg, new = 0;
    Tcl_WideInt incrValue = 1, currValue = 0;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvAppendObjCmd(
               void *arg,                     /* Pointer to object container */
               Tcl_Interp *interp,                 /* Current interpreter. */
               int objc,                   /* Number of arguments. */
               Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i, off, flg, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvPopObjCmd(
            void *arg,                     /* Pointer to object container */
            Tcl_Interp *interp,                 /* Current interpreter. */
            int objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off;
    Tcl_Obj *retObj;
    Array *arrayPtr = NULL;
    Container *svObj = (Container*)arg;

................................................................................
    retObj = svObj->tclObj;
    svObj->tclObj = NULL;

    if (DeleteContainer(svObj) != TCL_OK) {
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            const char *err = psPtr->psError(psPtr->psHandle);
            Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
        }
        ret = TCL_ERROR;
        goto cmd_exit;
    }

    if ((objc - off) == 0) {
        Tcl_SetObjResult(interp, retObj);
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvMoveObjCmd(
             void *arg,                     /* Pointer to object container. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off, new;
    const char *toKey;
    Tcl_HashEntry *hPtr;
    Container *svObj = (Container*)arg;

................................................................................
    }
    if (svObj->entryPtr) {
        char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
                return TCL_ERROR;
            }
        }
        Tcl_DeleteHashEntry(svObj->entryPtr);
    }

    svObj->entryPtr = hPtr;
................................................................................
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
SvLockObjCmd(
             void *dummy,                   /* Not used. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret;
    Tcl_Obj *scriptObj;
    Bucket *bucketPtr;
    Array *arrayPtr = NULL;

................................................................................
    ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_AUTO_LENGTH));
    }

    /*
     * We unlock the bucket directly, w/o going to Sv_Unlock()
     * since it needs the array which may be unset by the script.
     */

................................................................................
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
SvHandlersObjCmd(
             void *arg,                     /* Not used. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                           /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    PsStore *tmpPtr = NULL;

    /*
................................................................................

    /*
     * Plug-in registered commands in current interpreter
     */

    for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr,
                NULL, NULL);
#ifdef NS_AOLSERVER
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr,
                (void *)(size_t)cmdPtr->aolSpecial, NULL);
#endif
    }

    /*
     * Create array of buckets and initialize each bucket
     */

    if (buckets == NULL) {
        Tcl_MutexLock(&bucketsMutex);
        if (buckets == NULL) {
            buckets = Tcl_Alloc(sizeof(Bucket) * NUMBUCKETS);

            for (i = 0; i < NUMBUCKETS; ++i) {
                bucketPtr = &buckets[i];
                memset(bucketPtr, 0, sizeof(Bucket));
                Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
                Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS);
            }
................................................................................
 * Side effects
 *    Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */

static void
SvFinalize (void *clientData)
{
    register int i;
    SvCmdInfo *cmdPtr;
    RegType *regPtr;

    Tcl_HashEntry *hashPtr;
    Tcl_HashSearch search;
................................................................................
                if (bucketPtr->lock) {
                    Sp_RecursiveMutexFinalize(&bucketPtr->lock);
                }
                SvFinalizeContainers(bucketPtr);
                Tcl_DeleteHashTable(&bucketPtr->handles);
                Tcl_DeleteHashTable(&bucketPtr->arrays);
            }
            Tcl_Free(buckets), buckets = NULL;
        }
        buckets = NULL;
        Tcl_MutexUnlock(&bucketsMutex);
    }

    Tcl_MutexLock(&svMutex);

................................................................................
     * Reclaim memory for registered commands
     */

    if (svCmdInfo != NULL) {
        cmdPtr = svCmdInfo;
        while (cmdPtr) {
            SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
            Tcl_Free(cmdPtr);
            cmdPtr = tmpPtr;
        }
        svCmdInfo = NULL;
    }

    /*
     * Reclaim memory for registered object types
     */

    if (regType != NULL) {
        regPtr = regType;
        while (regPtr) {
            RegType *tmpPtr = regPtr->nextPtr;
            Tcl_Free(regPtr);
            regPtr = tmpPtr;
        }
        regType = NULL;
    }

    Tcl_MutexUnlock(&svMutex);

Changes to generic/threadSvCmd.h.

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
#define SV_ERROR          -1   /* Object may be in incosistent state */

/*
 * Definitions of functions implementing simple key/value
 * persistent storage for shared variable arrays.
 */

typedef ClientData (ps_open_proc)(const char*);

typedef int (ps_get_proc)   (ClientData, const char*, char**, size_t*);
typedef int (ps_put_proc)   (ClientData, const char*, char*, size_t);
typedef int (ps_first_proc) (ClientData, char**, char**, size_t*);
typedef int (ps_next_proc)  (ClientData, char**, char**, size_t*);
typedef int (ps_delete_proc)(ClientData, const char*);
typedef int (ps_close_proc) (ClientData);
typedef void(ps_free_proc)  (ClientData, void*);

typedef const char* (ps_geterr_proc)(ClientData);

/*
 * This structure maintains a bunch of pointers to functions implementing
 * the simple persistence layer for the shared variable arrays.
 */

typedef struct PsStore {
    const char *type;          /* Type identifier of the persistent storage */
    ClientData psHandle;       /* Handle to the opened storage */
    ps_open_proc   *psOpen;    /* Function to open the persistent key store */
    ps_get_proc    *psGet;     /* Function to retrieve value bound to key */
    ps_put_proc    *psPut;     /* Function to store user key and value */
    ps_first_proc  *psFirst;   /* Function to retrieve the first key/value */
    ps_next_proc   *psNext;    /* Function to retrieve the next key/value */
    ps_delete_proc *psDelete;  /* Function to delete user key and value */
    ps_close_proc  *psClose;   /* Function to close the persistent store */






|

|
|
|
|
|
|
|

|








|







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
#define SV_ERROR          -1   /* Object may be in incosistent state */

/*
 * Definitions of functions implementing simple key/value
 * persistent storage for shared variable arrays.
 */

typedef void *(ps_open_proc)(const char*);

typedef int (ps_get_proc)   (void *, const char*, char**, size_t*);
typedef int (ps_put_proc)   (void *, const char*, char*, size_t);
typedef int (ps_first_proc) (void *, char**, char**, size_t*);
typedef int (ps_next_proc)  (void *, char**, char**, size_t*);
typedef int (ps_delete_proc)(void *, const char*);
typedef int (ps_close_proc) (void *);
typedef void(ps_free_proc)  (void *, void*);

typedef const char* (ps_geterr_proc)(void *);

/*
 * This structure maintains a bunch of pointers to functions implementing
 * the simple persistence layer for the shared variable arrays.
 */

typedef struct PsStore {
    const char *type;          /* Type identifier of the persistent storage */
    void *psHandle;            /* Handle to the opened storage */
    ps_open_proc   *psOpen;    /* Function to open the persistent key store */
    ps_get_proc    *psGet;     /* Function to retrieve value bound to key */
    ps_put_proc    *psPut;     /* Function to store user key and value */
    ps_first_proc  *psFirst;   /* Function to retrieve the first key/value */
    ps_next_proc   *psNext;    /* Function to retrieve the next key/value */
    ps_delete_proc *psDelete;  /* Function to delete user key and value */
    ps_close_proc  *psClose;   /* Function to close the persistent store */

Changes to generic/threadSvKeylistCmd.c.

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylsetObjCmd(arg, interp, objc, objv)
    ClientData arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int i, off, ret, flg;
    char *key;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylgetObjCmd(arg, interp, objc, objv)
    ClientData arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, flg, off;
    char *key;
    Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
    Container *svObj = (Container*)arg;

................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeyldelObjCmd(arg, interp, objc, objv)
    ClientData arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int i, off, ret;
    char *key;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylkeysObjCmd(arg, interp, objc, objv)
    ClientData arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    STRLEN_TYPE objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, off;
    char *key = NULL;
    Tcl_Obj *listObj = NULL;
    Container *svObj = (Container*)arg;







|

|







 







|

|







 







|

|







 







|

|







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylsetObjCmd(arg, interp, objc, objv)
    void *arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int i, off, ret, flg;
    char *key;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylgetObjCmd(arg, interp, objc, objv)
    void *arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, flg, off;
    char *key;
    Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
    Container *svObj = (Container*)arg;

................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeyldelObjCmd(arg, interp, objc, objv)
    void *arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int i, off, ret;
    char *key;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylkeysObjCmd(arg, interp, objc, objv)
    void *arg;                     /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *const objv[];              /* Argument objects. */
{
    int ret, off;
    char *key = NULL;
    Tcl_Obj *listObj = NULL;
    Container *svObj = (Container*)arg;

Changes to generic/threadSvListCmd.c.

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
...
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
...
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
...
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
...
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
...
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
...
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
...
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
...
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
...
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
...
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
static Tcl_Mutex initMutex;

/*
 * Functions for implementing the "lset" list command
 */

static Tcl_Obj*
SvLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, STRLEN_TYPE indexCount,
           Tcl_Obj **indexArray, Tcl_Obj *valuePtr);

 
/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterListCommands --
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpopObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int ret, off, index = 0, iarg = 0;
    STRLEN_TYPE llen;
    Tcl_Obj *elPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpop array key ?index?
     *          $list lpop ?index?
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpushObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, index = 0;
    STRLEN_TYPE llen;
    Tcl_Obj *args[1];
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpush array key element ?index?
     *          $list lpush element ?index?
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLappendObjCmd(arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int i, ret, flg, off;
    Tcl_Obj *dup;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLreplaceObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    const char *firstArg;
    size_t argLen;
    int ret, off, llen, first, last, ndel, nargs, i, j;
    Tcl_Obj **args = NULL;
    Container *svObj = (Container*)arg;
................................................................................
        ndel = last - first + 1;
    } else {
        ndel = 0;
    }

    nargs = objc - (off + 2);
    if (nargs) {
        args = (Tcl_Obj**)ckalloc(nargs * sizeof(Tcl_Obj*));
        for(i = off + 2, j = 0; i < objc; i++, j++) {
            args[j] = Sv_DuplicateObj(objv[i]);
        }
    }

    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
    if (args) {
        if (ret != TCL_OK) {
            for(i = off + 2, j = 0; i < objc; i++, j++) {
                Tcl_DecrRefCount(args[j]);
            }
        }
        ckfree((char*)args);
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLrangeObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int ret, off, first, last, nargs, i, j;
    STRLEN_TYPE llen;
    Tcl_Obj **elPtrs, **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lrange array key first last
     *          $list lrange first last
................................................................................
        last = llen - 1;
    }
    if (first > last) {
        goto cmd_ok;
    }

    nargs = last - first + 1;
    args  = (Tcl_Obj**)ckalloc(nargs * sizeof(Tcl_Obj*));
    for (i = first, j = 0; i <= last; i++, j++) {
        args[j] = Sv_DuplicateObj(elPtrs[i]);
    }

    Tcl_ResetResult(interp);
    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
    ckfree((char*)args);

 cmd_ok:
    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLinsertObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, nargs, index = 0, i, j;
    STRLEN_TYPE llen;
    Tcl_Obj **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::linsert array key index element ?element ...?
     *          $list linsert element ?element ...?
................................................................................
    if (index < 0) {
        index = 0;
    } else if (index > llen) {
        index = llen;
    }

    nargs = objc - (off + 1);
    args  = (Tcl_Obj**)ckalloc(nargs * sizeof(Tcl_Obj*));
    for (i = off + 1, j = 0; i < objc; i++, j++) {
         args[j] = Sv_DuplicateObj(objv[i]);
    }
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
    if (ret != TCL_OK) {
        for (i = off + 1, j = 0; i < objc; i++, j++) {
            Tcl_DecrRefCount(args[j]);
        }
        ckfree((char*)args);
        goto cmd_err;
    }

    ckfree((char*)args);

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
 
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLlengthObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    int off, ret;
    STRLEN_TYPE llen;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::llength array key
     *          $list llength
     */
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsearchObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    size_t length;
    int ret, off, listc, mode, imode, ipatt, index, match, i;
    const char *patBytes;
    Tcl_Obj **listv;
    Container *svObj = (Container*)arg;
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLindexObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj **elPtrs;
    int ret, off, index;
    STRLEN_TYPE llen;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lindex array key index
     *          $list lindex index
     */
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsetObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    STRLEN_TYPE objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj *lPtr;
    int ret, argc, off;
    Container *svObj = (Container*)arg;

    /*
................................................................................

static void
DupListObjShared(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
{
    int i;
    STRLEN_TYPE llen;
    Tcl_Obj *elObj, **newObjList;

    Tcl_ListObjLength(NULL, srcPtr, &llen);
    if (llen == 0) {
        (*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
        copyPtr->refCount = 0;
        return;
    }

    newObjList = (Tcl_Obj**)ckalloc(llen*sizeof(Tcl_Obj*));

    for (i = 0; i < llen; i++) {
        Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
        newObjList[i] = Sv_DuplicateObj(elObj);
    }

    Tcl_SetListObj(copyPtr, llen, newObjList);

    ckfree((char*)newObjList);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * SvGetIntForIndex --
 *
................................................................................
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
     Tcl_Interp *interp;     /* Tcl interpreter */
     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
     STRLEN_TYPE indexCount;         /* Number of index args */
     Tcl_Obj **indexArray;
     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
{
    int index, result, i;
    STRLEN_TYPE elemCount;
    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

    /*
     * Determine whether the index arg designates a list
     * or a single index.
     */







|







 







|

|



|







 







|

|



|







 







|

|







 







|

|







 







|












|







 







|

|



|







 







|






|







 







|

|



|







 







|








|



|







 







|

|



|







 







|

|







 







|

|




|







 







|

|







 







|









|








|







 







|




|







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
...
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
...
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
...
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
...
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
...
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
...
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
...
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
...
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
...
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
...
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
static Tcl_Mutex initMutex;

/*
 * Functions for implementing the "lset" list command
 */

static Tcl_Obj*
SvLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount,
           Tcl_Obj **indexArray, Tcl_Obj *valuePtr);

 
/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterListCommands --
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpopObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, index = 0, iarg = 0;
    int llen;
    Tcl_Obj *elPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpop array key ?index?
     *          $list lpop ?index?
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpushObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, index = 0;
    int llen;
    Tcl_Obj *args[1];
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpush array key element ?index?
     *          $list lpush element ?index?
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLappendObjCmd(arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int i, ret, flg, off;
    Tcl_Obj *dup;
    Container *svObj = (Container*)arg;

    /*
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLreplaceObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    const char *firstArg;
    size_t argLen;
    int ret, off, llen, first, last, ndel, nargs, i, j;
    Tcl_Obj **args = NULL;
    Container *svObj = (Container*)arg;
................................................................................
        ndel = last - first + 1;
    } else {
        ndel = 0;
    }

    nargs = objc - (off + 2);
    if (nargs) {
        args = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
        for(i = off + 2, j = 0; i < objc; i++, j++) {
            args[j] = Sv_DuplicateObj(objv[i]);
        }
    }

    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
    if (args) {
        if (ret != TCL_OK) {
            for(i = off + 2, j = 0; i < objc; i++, j++) {
                Tcl_DecrRefCount(args[j]);
            }
        }
        Tcl_Free(args);
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLrangeObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, first, last, nargs, i, j;
    int llen;
    Tcl_Obj **elPtrs, **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lrange array key first last
     *          $list lrange first last
................................................................................
        last = llen - 1;
    }
    if (first > last) {
        goto cmd_ok;
    }

    nargs = last - first + 1;
    args  = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = first, j = 0; i <= last; i++, j++) {
        args[j] = Sv_DuplicateObj(elPtrs[i]);
    }

    Tcl_ResetResult(interp);
    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
    Tcl_Free(args);

 cmd_ok:
    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLinsertObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, nargs, index = 0, i, j;
    int llen;
    Tcl_Obj **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::linsert array key index element ?element ...?
     *          $list linsert element ?element ...?
................................................................................
    if (index < 0) {
        index = 0;
    } else if (index > llen) {
        index = llen;
    }

    nargs = objc - (off + 1);
    args  = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = off + 1, j = 0; i < objc; i++, j++) {
         args[j] = Sv_DuplicateObj(objv[i]);
    }
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
    if (ret != TCL_OK) {
        for (i = off + 1, j = 0; i < objc; i++, j++) {
            Tcl_DecrRefCount(args[j]);
        }
        Tcl_Free(args);
        goto cmd_err;
    }

    Tcl_Free(args);

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}
 
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLlengthObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret;
    int llen;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::llength array key
     *          $list llength
     */
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsearchObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    size_t length;
    int ret, off, listc, mode, imode, ipatt, index, match, i;
    const char *patBytes;
    Tcl_Obj **listv;
    Container *svObj = (Container*)arg;
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLindexObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj **elPtrs;
    int ret, off, index;
    int llen;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lindex array key index
     *          $list lindex index
     */
................................................................................
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsetObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj *lPtr;
    int ret, argc, off;
    Container *svObj = (Container*)arg;

    /*
................................................................................

static void
DupListObjShared(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
{
    int i;
    int llen;
    Tcl_Obj *elObj, **newObjList;

    Tcl_ListObjLength(NULL, srcPtr, &llen);
    if (llen == 0) {
        (*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
        copyPtr->refCount = 0;
        return;
    }

    newObjList = Tcl_Alloc(llen*sizeof(Tcl_Obj*));

    for (i = 0; i < llen; i++) {
        Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
        newObjList[i] = Sv_DuplicateObj(elObj);
    }

    Tcl_SetListObj(copyPtr, llen, newObjList);

    Tcl_Free(newObjList);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * SvGetIntForIndex --
 *
................................................................................
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
     Tcl_Interp *interp;     /* Tcl interpreter */
     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
     int indexCount;         /* Number of index args */
     Tcl_Obj **indexArray;
     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
{
    int index, result, i;
    int elemCount;
    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

    /*
     * Determine whether the index arg designates a list
     * or a single index.
     */