1 /*
2 * This file implements a family of commands for sharing variables
3 * between threads.
4 *
5 * Initial code is taken from nsd/tclvar.c found in AOLserver 3.+
6 * distribution and modified to support Tcl 8.0+ command object interface
7 * and internal storage in private shared Tcl objects.
8 *
9 * Copyright (c) 2002 by Zoran Vasiljevic.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 * ----------------------------------------------------------------------------
14 */
15
16 #include "tclThreadInt.h"
17 #include "threadSvCmd.h"
18
19 #include "threadSvListCmd.h" /* Shared variants of list commands */
20 #include "threadSvKeylistCmd.h" /* Shared variants of list commands */
21 #include "psGdbm.h" /* The gdbm persistent store implementation */
22 #include "psLmdb.h" /* The lmdb persistent store implementation */
23
24 #define SV_FINALIZE
25
26 /*
27 * Number of buckets to spread shared arrays into. Each bucket is
28 * associated with one mutex so locking a bucket locks all arrays
29 * in that bucket as well. The number of buckets should be a prime.
30 */
31
32 #define NUMBUCKETS 31
33
34 /*
35 * Number of object containers
36 * to allocate in one shot.
37 */
38
39 #define OBJS_TO_ALLOC_EACH_TIME 100
40
41 /*
42 * Reference to Tcl object types used in object-copy code.
43 * Those are referenced read-only, thus no mutex protection.
44 */
45
46 static const Tcl_ObjType* booleanObjTypePtr = 0;
47 static const Tcl_ObjType* byteArrayObjTypePtr = 0;
48 static const Tcl_ObjType* doubleObjTypePtr = 0;
49 static const Tcl_ObjType* intObjTypePtr = 0;
50 static const Tcl_ObjType* wideIntObjTypePtr = 0;
51 static const Tcl_ObjType* stringObjTypePtr = 0;
52
53 /*
54 * In order to be fully stub enabled, a small
55 * hack is needed to query the tclEmptyStringRep
56 * global symbol defined by Tcl. See SvInit.
57 */
58
59 static char *Sv_tclEmptyStringRep = NULL;
60
61 /*
62 * Global variables used within this file.
63 */
64
65 #ifdef SV_FINALIZE
66 static size_t nofThreads; /* Number of initialized threads */
67 static Tcl_Mutex nofThreadsMutex; /* Protects the nofThreads variable */
68 #endif /* SV_FINALIZE */
69
70 static Bucket* buckets; /* Array of buckets. */
71 static Tcl_Mutex bucketsMutex; /* Protects the array of buckets */
72
73 static SvCmdInfo* svCmdInfo; /* Linked list of registered commands */
74 static RegType* regType; /* Linked list of registered obj types */
75 static PsStore* psStore; /* Linked list of registered pers. stores */
76
77 static Tcl_Mutex svMutex; /* Protects inserts into above lists */
78 static Tcl_Mutex initMutex; /* Serializes initialization issues */
79
80 /*
81 * The standard commands found in NaviServer/AOLserver nsv_* interface.
82 * For sharp-eye readers: the implementation of the "lappend" command
83 * is moved to new list-command package, since it really belongs there.
84 */
85
86 static Tcl_ObjCmdProc SvObjObjCmd;
87 static Tcl_ObjCmdProc SvAppendObjCmd;
88 static Tcl_ObjCmdProc SvIncrObjCmd;
89 static Tcl_ObjCmdProc SvSetObjCmd;
90 static Tcl_ObjCmdProc SvExistsObjCmd;
91 static Tcl_ObjCmdProc SvGetObjCmd;
92 static Tcl_ObjCmdProc SvArrayObjCmd;
93 static Tcl_ObjCmdProc SvUnsetObjCmd;
94 static Tcl_ObjCmdProc SvNamesObjCmd;
95 static Tcl_ObjCmdProc SvHandlersObjCmd;
96
97 /*
98 * New commands added to
99 * standard set of nsv_*
100 */
101
102 static Tcl_ObjCmdProc SvPopObjCmd;
103 static Tcl_ObjCmdProc SvMoveObjCmd;
104 static Tcl_ObjCmdProc SvLockObjCmd;
105
106 /*
107 * Forward declarations for functions to
108 * manage buckets, arrays and shared objects.
109 */
110
111 static Container* CreateContainer(Array*, Tcl_HashEntry*, Tcl_Obj*);
112 static Container* AcquireContainer(Array*, const char*, int);
113
114 static Array* CreateArray(Bucket*, const char*);
115 static Array* LockArray(Tcl_Interp*, const char*, int);
116
117 static int ReleaseContainer(Tcl_Interp*, Container*, int);
118 static int DeleteContainer(Container*);
119 static int FlushArray(Array*);
120 static int DeleteArray(Tcl_Interp *, Array*);
121
122 static void SvAllocateContainers(Bucket*);
123 static void SvRegisterStdCommands(void);
124
125 #ifdef SV_FINALIZE
126 static void SvFinalizeContainers(Bucket*);
127 static void SvFinalize(ClientData);
128 #endif /* SV_FINALIZE */
129
130 static PsStore* GetPsStore(const char *handle);
131
132 static int SvObjDispatchObjCmd(ClientData arg,
133 Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
134
135 /*
136 *-----------------------------------------------------------------------------
137 *
138 * Sv_RegisterCommand --
139 *
140 * Utility to register commands to be loaded at module start.
141 *
142 * Results:
143 * None.
144 *
145 * Side effects;
146 * New command will be added to a linked list of registered commands.
147 *
148 *-----------------------------------------------------------------------------
149 */
150
151 void
Sv_RegisterCommand(const char * cmdName,Tcl_ObjCmdProc * objProc,Tcl_CmdDeleteProc * delProc,int aolSpecial)152 Sv_RegisterCommand(
153 const char *cmdName, /* Name of command to register */
154 Tcl_ObjCmdProc *objProc, /* Object-based command procedure */
155 Tcl_CmdDeleteProc *delProc, /* Command delete procedure */
156 int aolSpecial)
157 {
158 size_t len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
159 size_t len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
160 SvCmdInfo *newCmd = (SvCmdInfo*)ckalloc(sizeof(SvCmdInfo) + len + len2);
161
162 /*
163 * Setup new command structure
164 */
165
166 newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));
167 newCmd->cmdName2 = newCmd->cmdName + len;
168 newCmd->aolSpecial = aolSpecial;
169
170 newCmd->objProcPtr = objProc;
171 newCmd->delProcPtr = delProc;
172
173 /*
174 * Rewrite command name. This is needed so we can
175 * easily turn-on the compatiblity with NaviServer/AOLserver
176 * command names.
177 */
178
179 strcpy(newCmd->cmdName, TSV_CMD_PREFIX);
180 strcat(newCmd->cmdName, cmdName);
181 newCmd->name = newCmd->cmdName + strlen(TSV_CMD_PREFIX);
182 strcpy(newCmd->cmdName2, TSV_CMD2_PREFIX);
183 strcat(newCmd->cmdName2, cmdName);
184
185 /*
186 * Plug-in in shared list of commands.
187 */
188
189 Tcl_MutexLock(&svMutex);
190 if (svCmdInfo == NULL) {
191 svCmdInfo = newCmd;
192 newCmd->nextPtr = NULL;
193 } else {
194 newCmd->nextPtr = svCmdInfo;
195 svCmdInfo = newCmd;
196 }
197 Tcl_MutexUnlock(&svMutex);
198
199 return;
200 }
201
202 /*
203 *-----------------------------------------------------------------------------
204 *
205 * Sv_RegisterObjType --
206 *
207 * Registers custom object duplicator function for a specific
208 * object type. Registered function will be called by the
209 * private object creation routine every time an object is
210 * plugged out or in the shared array. This way we assure that
211 * Tcl objects do not get shared per-reference between threads.
212 *
213 * Results:
214 * None.
215 *
216 * Side effects;
217 * Memory gets allocated.
218 *
219 *-----------------------------------------------------------------------------
220 */
221
222 void
Sv_RegisterObjType(const Tcl_ObjType * typePtr,Tcl_DupInternalRepProc * dupProc)223 Sv_RegisterObjType(
224 const Tcl_ObjType *typePtr, /* Type of object to register */
225 Tcl_DupInternalRepProc *dupProc) /* Custom object duplicator */
226 {
227 RegType *newType = (RegType*)ckalloc(sizeof(RegType));
228
229 /*
230 * Setup new type structure
231 */
232
233 newType->typePtr = typePtr;
234 newType->dupIntRepProc = dupProc;
235
236 /*
237 * Plug-in in shared list
238 */
239
240 Tcl_MutexLock(&svMutex);
241 newType->nextPtr = regType;
242 regType = newType;
243 Tcl_MutexUnlock(&svMutex);
244 }
245
246 /*
247 *-----------------------------------------------------------------------------
248 *
249 * Sv_RegisterPsStore --
250 *
251 * Registers a handler to the persistent storage.
252 *
253 * Results:
254 * None.
255 *
256 * Side effects;
257 * Memory gets allocated.
258 *
259 *-----------------------------------------------------------------------------
260 */
261
262 void
Sv_RegisterPsStore(const PsStore * psStorePtr)263 Sv_RegisterPsStore(const PsStore *psStorePtr)
264 {
265
266 PsStore *psPtr = (PsStore*)ckalloc(sizeof(PsStore));
267
268 *psPtr = *psStorePtr;
269
270 /*
271 * Plug-in in shared list
272 */
273
274 Tcl_MutexLock(&svMutex);
275 if (psStore == NULL) {
276 psStore = psPtr;
277 psStore->nextPtr = NULL;
278 } else {
279 psPtr->nextPtr = psStore;
280 psStore = psPtr;
281 }
282 Tcl_MutexUnlock(&svMutex);
283 }
284
285 /*
286 *-----------------------------------------------------------------------------
287 *
288 * Sv_GetContainer --
289 *
290 * This is the workhorse of the module. It returns the container
291 * with the shared Tcl object. It also locks the container, so
292 * when finished with operation on the Tcl object, one has to
293 * unlock the container by calling the Sv_PutContainer().
294 * If instructed, this command might also create new container
295 * with empty Tcl object.
296 *
297 * Results:
298 * A standard Tcl result.
299 *
300 * Side effects:
301 * New container might be created.
302 *
303 *-----------------------------------------------------------------------------
304 */
305
306 int
Sv_GetContainer(Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],Container ** retObj,int * offset,int flags)307 Sv_GetContainer(
308 Tcl_Interp *interp, /* Current interpreter. */
309 int objc, /* Number of arguments */
310 Tcl_Obj *const objv[], /* Argument objects. */
311 Container **retObj, /* OUT: shared object container */
312 int *offset, /* Shift in argument list */
313 int flags) /* Options for locking shared array */
314 {
315 const char *array, *key;
316
317 if (*retObj == NULL) {
318 Array *arrayPtr = NULL;
319
320 /*
321 * Parse mandatory arguments: <cmd> array key
322 */
323
324 if (objc < 3) {
325 Tcl_WrongNumArgs(interp, 1, objv, "array key ?args?");
326 return TCL_ERROR;
327 }
328
329 array = Tcl_GetString(objv[1]);
330 key = Tcl_GetString(objv[2]);
331
332 *offset = 3; /* Consumed three arguments: cmd, array, key */
333
334 /*
335 * Lock the shared array and locate the shared object
336 */
337
338 arrayPtr = LockArray(interp, array, flags);
339 if (arrayPtr == NULL) {
340 return TCL_BREAK;
341 }
342 *retObj = AcquireContainer(arrayPtr, Tcl_GetString(objv[2]), flags);
343 if (*retObj == NULL) {
344 UnlockArray(arrayPtr);
345 Tcl_AppendResult(interp, "no key ", array, "(", key, ")", NULL);
346 return TCL_BREAK;
347 }
348 } else {
349 Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles);
350 LOCK_CONTAINER(*retObj);
351 if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) {
352 UNLOCK_CONTAINER(*retObj);
353 Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", -1));
354 return TCL_BREAK;
355 }
356 *offset = 2; /* Consumed two arguments: object, cmd */
357 }
358
359 return TCL_OK;
360 }
361
362 /*
363 *-----------------------------------------------------------------------------
364 *
365 * Sv_PutContainer --
366 *
367 * Releases the container obtained by the Sv_GetContainer.
368 *
369 * Results:
370 * A standard Tcl result.
371 *
372 * Side effects:
373 * For bound arrays, update the underlying persistent storage.
374 *
375 *-----------------------------------------------------------------------------
376 */
377
378 int
Sv_PutContainer(Tcl_Interp * interp,Container * svObj,int mode)379 Sv_PutContainer(
380 Tcl_Interp *interp, /* For error reporting; might be NULL */
381 Container *svObj, /* Shared object container */
382 int mode) /* One of SV_XXX modes */
383 {
384 int ret;
385
386 ret = ReleaseContainer(interp, svObj, mode);
387 UnlockArray(svObj->arrayPtr);
388
389 return ret;
390 }
391
392 /*
393 *-----------------------------------------------------------------------------
394 *
395 * GetPsStore --
396 *
397 * Performs a lookup in the list of registered persistent storage
398 * handlers. If the match is found, duplicates the persistent
399 * storage record and passes the copy to the caller.
400 *
401 * Results:
402 * Pointer to the newly allocated persistent storage handler. Caller
403 * must free this block when done with it. If none found, returns NULL,
404 *
405 * Side effects;
406 * Memory gets allocated. Caller should free the return value of this
407 * function using ckfree().
408 *
409 *-----------------------------------------------------------------------------
410 */
411
412 static PsStore*
GetPsStore(const char * handle)413 GetPsStore(const char *handle)
414 {
415 int i;
416 const char *type = handle;
417 char *addr, *delimiter = (char *)strchr(handle, ':');
418 PsStore *tmpPtr, *psPtr = NULL;
419
420 /*
421 * Expect the handle in the following format: <type>:<address>
422 * where "type" must match one of the registered presistent store
423 * types (gdbm, tcl, whatever) and <address> is what is passed to
424 * the open procedure of the registered store.
425 *
426 * Example: gdbm:/path/to/gdbm/file
427 */
428
429 /*
430 * Try to see wether some array is already bound to the
431 * same persistent storage address.
432 */
433
434 for (i = 0; i < NUMBUCKETS; i++) {
435 Tcl_HashSearch search;
436 Tcl_HashEntry *hPtr;
437 Bucket *bucketPtr = &buckets[i];
438 LOCK_BUCKET(bucketPtr);
439 hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
440 while (hPtr) {
441 Array *arrayPtr = (Array*)Tcl_GetHashValue(hPtr);
442 if (arrayPtr->bindAddr && arrayPtr->psPtr) {
443 if (strcmp(arrayPtr->bindAddr, handle) == 0) {
444 UNLOCK_BUCKET(bucketPtr);
445 return NULL; /* Array already bound */
446 }
447 }
448 hPtr = Tcl_NextHashEntry(&search);
449 }
450 UNLOCK_BUCKET(bucketPtr);
451 }
452
453 /*
454 * Split the address and storage handler
455 */
456
457 if (delimiter == NULL) {
458 addr = NULL;
459 } else {
460 *delimiter = 0;
461 addr = delimiter + 1;
462 }
463
464 /*
465 * No array was bound to the same persistent storage.
466 * Lookup the persistent storage to bind to.
467 */
468
469 Tcl_MutexLock(&svMutex);
470 for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
471 if (strcmp(tmpPtr->type, type) == 0) {
472 tmpPtr->psHandle = tmpPtr->psOpen(addr);
473 if (tmpPtr->psHandle) {
474 psPtr = (PsStore*)ckalloc(sizeof(PsStore));
475 *psPtr = *tmpPtr;
476 psPtr->nextPtr = NULL;
477 }
478 break;
479 }
480 }
481 Tcl_MutexUnlock(&svMutex);
482
483 if (delimiter) {
484 *delimiter = ':';
485 }
486
487 return psPtr;
488 }
489
490 /*
491 *-----------------------------------------------------------------------------
492 *
493 * AcquireContainer --
494 *
495 * Finds a variable within an array and returns it's container.
496 *
497 * Results:
498 * Pointer to variable object.
499 *
500 * Side effects;
501 * New variable may be created. For bound arrays, try to locate
502 * the key in the persistent storage as well.
503 *
504 *-----------------------------------------------------------------------------
505 */
506
507 static Container *
AcquireContainer(Array * arrayPtr,const char * key,int flags)508 AcquireContainer(
509 Array *arrayPtr,
510 const char *key,
511 int flags)
512 {
513 int isNew;
514 Tcl_Obj *tclObj = NULL;
515 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
516
517 if (hPtr == NULL) {
518 PsStore *psPtr = arrayPtr->psPtr;
519 if (psPtr) {
520 char *val = NULL;
521 size_t len = 0;
522 if (psPtr->psGet(psPtr->psHandle, key, &val, &len) == 0) {
523 tclObj = Tcl_NewStringObj(val, len);
524 psPtr->psFree(psPtr->psHandle, val);
525 }
526 }
527 if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) {
528 return NULL;
529 }
530 if (tclObj == NULL) {
531 tclObj = Tcl_NewObj();
532 }
533 hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew);
534 Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
535 }
536
537 return (Container*)Tcl_GetHashValue(hPtr);
538 }
539
540 /*
541 *-----------------------------------------------------------------------------
542 *
543 * ReleaseContainer --
544 *
545 * Does some post-processing on the used container. This is mostly
546 * needed when the container has been modified and needs to be
547 * saved in the bound persistent storage.
548 *
549 * Results:
550 * A standard Tcl result
551 *
552 * Side effects:
553 * Persistent storage, if bound, might be modified.
554 *
555 *-----------------------------------------------------------------------------
556 */
557
558 static int
ReleaseContainer(Tcl_Interp * interp,Container * svObj,int mode)559 ReleaseContainer(
560 Tcl_Interp *interp,
561 Container *svObj,
562 int mode)
563 {
564 const PsStore *psPtr = svObj->arrayPtr->psPtr;
565 size_t len;
566 char *key, *val;
567
568 switch (mode) {
569 case SV_UNCHANGED: return TCL_OK;
570 case SV_ERROR: return TCL_ERROR;
571 case SV_CHANGED:
572 if (psPtr) {
573 key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
574 val = Tcl_GetString(svObj->tclObj);
575 len = svObj->tclObj->length;
576 if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) {
577 const char *err = psPtr->psError(psPtr->psHandle);
578 Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
579 return TCL_ERROR;
580 }
581 }
582 return TCL_OK;
583 }
584
585 return TCL_ERROR; /* Should never be reached */
586 }
587
588 /*
589 *-----------------------------------------------------------------------------
590 *
591 * CreateContainer --
592 *
593 * Creates new shared container holding Tcl object to be stored
594 * in the shared array
595 *
596 * Results:
597 * The container pointer.
598 *
599 * Side effects:
600 * Memory gets allocated.
601 *
602 *-----------------------------------------------------------------------------
603 */
604
605 static Container *
CreateContainer(Array * arrayPtr,Tcl_HashEntry * entryPtr,Tcl_Obj * tclObj)606 CreateContainer(
607 Array *arrayPtr,
608 Tcl_HashEntry *entryPtr,
609 Tcl_Obj *tclObj)
610 {
611 Container *svObj;
612
613 if (arrayPtr->bucketPtr->freeCt == NULL) {
614 SvAllocateContainers(arrayPtr->bucketPtr);
615 }
616
617 svObj = arrayPtr->bucketPtr->freeCt;
618 arrayPtr->bucketPtr->freeCt = svObj->nextPtr;
619
620 svObj->arrayPtr = arrayPtr;
621 svObj->bucketPtr = arrayPtr->bucketPtr;
622 svObj->tclObj = tclObj;
623 svObj->entryPtr = entryPtr;
624 svObj->handlePtr = NULL;
625
626 if (svObj->tclObj) {
627 Tcl_IncrRefCount(svObj->tclObj);
628 }
629
630 return svObj;
631 }
632
633 /*
634 *-----------------------------------------------------------------------------
635 *
636 * DeleteContainer --
637 *
638 * Destroys the container and the Tcl object within it. For bound
639 * shared arrays, the underlying persistent store is updated as well.
640 *
641 * Results:
642 * None.
643 *
644 * Side effects:
645 * Memory gets reclaimed. If the shared array was bound to persistent
646 * storage, it removes the corresponding record.
647 *
648 *-----------------------------------------------------------------------------
649 */
650
651 static int
DeleteContainer(Container * svObj)652 DeleteContainer(
653 Container *svObj)
654 {
655 if (svObj->tclObj) {
656 Tcl_DecrRefCount(svObj->tclObj);
657 }
658 if (svObj->handlePtr) {
659 Tcl_DeleteHashEntry(svObj->handlePtr);
660 }
661 if (svObj->entryPtr) {
662 PsStore *psPtr = svObj->arrayPtr->psPtr;
663 if (psPtr) {
664 char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr);
665 if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
666 return TCL_ERROR;
667 }
668 }
669 Tcl_DeleteHashEntry(svObj->entryPtr);
670 }
671
672 svObj->arrayPtr = NULL;
673 svObj->entryPtr = NULL;
674 svObj->handlePtr = NULL;
675 svObj->tclObj = NULL;
676
677 svObj->nextPtr = svObj->bucketPtr->freeCt;
678 svObj->bucketPtr->freeCt = svObj;
679
680 return TCL_OK;
681 }
682
683 /*
684 *-----------------------------------------------------------------------------
685 *
686 * LockArray --
687 *
688 * Find (or create) the array structure for shared array and lock it.
689 * Array structure must be later unlocked with UnlockArray.
690 *
691 * Results:
692 * TCL_OK or TCL_ERROR if no such array.
693 *
694 * Side effects:
695 * Sets *arrayPtrPtr with Array pointer or leave error in given interp.
696 *
697 *-----------------------------------------------------------------------------
698 */
699
700 static Array *
LockArray(Tcl_Interp * interp,const char * array,int flags)701 LockArray(
702 Tcl_Interp *interp, /* Interpreter to leave result. */
703 const char *array, /* Name of array to lock */
704 int flags) /* FLAGS_CREATEARRAY/FLAGS_NOERRMSG*/
705 {
706 const char *p;
707 unsigned int result;
708 int i;
709 Bucket *bucketPtr;
710 Array *arrayPtr;
711
712 /*
713 * Compute a hash to map an array to a bucket.
714 */
715
716 p = array;
717 result = 0;
718 while (*p++) {
719 i = *p;
720 result += (result << 3) + i;
721 }
722 i = result % NUMBUCKETS;
723 bucketPtr = &buckets[i];
724
725 /*
726 * Lock the bucket and find the array, or create a new one.
727 * The bucket will be left locked on success.
728 */
729
730 LOCK_BUCKET(bucketPtr); /* Note: no matching unlock below ! */
731 if (flags & FLAGS_CREATEARRAY) {
732 arrayPtr = CreateArray(bucketPtr, array);
733 } else {
734 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&bucketPtr->arrays, array);
735 if (hPtr == NULL) {
736 UNLOCK_BUCKET(bucketPtr);
737 if (!(flags & FLAGS_NOERRMSG)) {
738 Tcl_AppendResult(interp, "\"", array,
739 "\" is not a thread shared array", NULL);
740 }
741 return NULL;
742 }
743 arrayPtr = (Array*)Tcl_GetHashValue(hPtr);
744 }
745
746 return arrayPtr;
747 }
748 /*
749 *-----------------------------------------------------------------------------
750 *
751 * FlushArray --
752 *
753 * Unset all keys in an array.
754 *
755 * Results:
756 * None.
757 *
758 * Side effects:
759 * Array is cleaned but it's variable hash-hable still lives.
760 * For bound arrays, the persistent store is updated accordingly.
761 *
762 *-----------------------------------------------------------------------------
763 */
764
765 static int
FlushArray(Array * arrayPtr)766 FlushArray(Array *arrayPtr) /* Name of array to flush */
767 {
768 Tcl_HashEntry *hPtr;
769 Tcl_HashSearch search;
770
771 for (hPtr = Tcl_FirstHashEntry(&arrayPtr->vars, &search); hPtr;
772 hPtr = Tcl_NextHashEntry(&search)) {
773 if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) {
774 return TCL_ERROR;
775 }
776 }
777
778 return TCL_OK;
779 }
780
781 /*
782 *-----------------------------------------------------------------------------
783 *
784 * CreateArray --
785 *
786 * Creates new shared array instance.
787 *
788 * Results:
789 * Pointer to the newly created array
790 *
791 * Side effects:
792 * Memory gets allocated
793 *
794 *-----------------------------------------------------------------------------
795 */
796
797 static Array *
CreateArray(Bucket * bucketPtr,const char * arrayName)798 CreateArray(
799 Bucket *bucketPtr,
800 const char *arrayName)
801 {
802 int isNew;
803 Array *arrayPtr;
804 Tcl_HashEntry *hPtr;
805
806 hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &isNew);
807 if (!isNew) {
808 return (Array*)Tcl_GetHashValue(hPtr);
809 }
810
811 arrayPtr = (Array*)ckalloc(sizeof(Array));
812 arrayPtr->bucketPtr = bucketPtr;
813 arrayPtr->entryPtr = hPtr;
814 arrayPtr->psPtr = NULL;
815 arrayPtr->bindAddr = NULL;
816
817 Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS);
818 Tcl_SetHashValue(hPtr, arrayPtr);
819
820 return arrayPtr;
821 }
822
823 /*
824 *-----------------------------------------------------------------------------
825 *
826 * DeleteArray --
827 *
828 * Deletes the shared array.
829 *
830 * Results:
831 * A standard Tcl result.
832 *
833 * Side effects:
834 * Memory gets reclaimed.
835 *
836 *-----------------------------------------------------------------------------
837 */
838
839 static int
UnbindArray(Tcl_Interp * interp,Array * arrayPtr)840 UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
841 {
842 PsStore *psPtr = arrayPtr->psPtr;
843 if (arrayPtr->bindAddr) {
844 ckfree(arrayPtr->bindAddr);
845 arrayPtr->bindAddr = NULL;
846 }
847 if (psPtr) {
848 if (psPtr->psClose(psPtr->psHandle) == -1) {
849 if (interp) {
850 const char *err = psPtr->psError(psPtr->psHandle);
851 Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
852 }
853 return TCL_ERROR;
854 }
855 ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
856 arrayPtr->psPtr = NULL;
857 }
858 return TCL_OK;
859 }
860
861 static int
DeleteArray(Tcl_Interp * interp,Array * arrayPtr)862 DeleteArray(Tcl_Interp *interp, Array *arrayPtr)
863 {
864 if (FlushArray(arrayPtr) == -1) {
865 return TCL_ERROR;
866 }
867 if (arrayPtr->psPtr) {
868 if (UnbindArray(interp, arrayPtr) != TCL_OK) {
869 return TCL_ERROR;
870 };
871 }
872 if (arrayPtr->entryPtr) {
873 Tcl_DeleteHashEntry(arrayPtr->entryPtr);
874 }
875
876 Tcl_DeleteHashTable(&arrayPtr->vars);
877 ckfree((char*)arrayPtr);
878
879 return TCL_OK;
880 }
881
882 /*
883 *-----------------------------------------------------------------------------
884 *
885 * SvAllocateContainers --
886 *
887 * Any similarity with the Tcl AllocateFreeObj function is purely
888 * coincidental... Just joking; this is (almost) 100% copy of it! :-)
889 *
890 * Results:
891 * None.
892 *
893 * Side effects:
894 * Allocates memory for many containers at the same time
895 *
896 *-----------------------------------------------------------------------------
897 */
898
899 static void
SvAllocateContainers(Bucket * bucketPtr)900 SvAllocateContainers(Bucket *bucketPtr)
901 {
902 Container tmp[2];
903 size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp);
904 size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
905 char *basePtr;
906 Container *prevPtr = NULL, *objPtr = NULL;
907 int i;
908
909 basePtr = (char*)ckalloc(bytesToAlloc);
910 memset(basePtr, 0, bytesToAlloc);
911
912 objPtr = (Container*)basePtr;
913 objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */
914
915 for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
916 objPtr->nextPtr = prevPtr;
917 prevPtr = objPtr;
918 objPtr = (Container*)(((char*)objPtr) + objSizePlusPadding);
919 }
920 bucketPtr->freeCt = prevPtr;
921 }
922
923 #ifdef SV_FINALIZE
924 /*
925 *-----------------------------------------------------------------------------
926 *
927 * SvFinalizeContainers --
928 *
929 * Reclaim memory for free object containers per bucket.
930 *
931 * Results:
932 * None.
933 *
934 * Side effects:
935 * Memory gets reclaimed
936 *
937 *-----------------------------------------------------------------------------
938 */
939
940 static void
SvFinalizeContainers(Bucket * bucketPtr)941 SvFinalizeContainers(Bucket *bucketPtr)
942 {
943 Container *tmpPtr, *objPtr = bucketPtr->freeCt;
944
945 while (objPtr) {
946 if (objPtr->chunkAddr == (char*)objPtr) {
947 tmpPtr = objPtr->nextPtr;
948 ckfree((char*)objPtr);
949 objPtr = tmpPtr;
950 } else {
951 objPtr = objPtr->nextPtr;
952 }
953 }
954 }
955 #endif /* SV_FINALIZE */
956
957 /*
958 *-----------------------------------------------------------------------------
959 *
960 * Sv_DuplicateObj --
961 *
962 * Create and return a new object that is (mostly) a duplicate of the
963 * argument object. We take care that the duplicate object is either
964 * a proper object copy, i.e. w/o hidden references to original object
965 * elements or a plain string object, i.e one w/o internal representation.
966 *
967 * Decision about whether to produce a real duplicate or a string object
968 * is done as follows:
969 *
970 * 1) Scalar Tcl object types are properly copied by default;
971 * these include: boolean, int double, string and byteArray types.
972 * 2) Object registered with Sv_RegisterObjType are duplicated
973 * using custom duplicator function which is guaranteed to
974 * produce a proper deep copy of the object in question.
975 * 3) All other object types are stringified; these include
976 * miscelaneous Tcl objects (cmdName, nsName, bytecode, etc, etc)
977 * and all user-defined objects.
978 *
979 * Results:
980 * The return value is a pointer to a newly created Tcl_Obj. This
981 * object has reference count 0 and the same type, if any, as the
982 * source object objPtr. Also:
983 *
984 * 1) If the source object has a valid string rep, we copy it;
985 * otherwise, the new string rep is marked invalid.
986 * 2) If the source object has an internal representation (i.e. its
987 * typePtr is non-NULL), the new object's internal rep is set to
988 * a copy; otherwise the new internal rep is marked invalid.
989 *
990 * Side effects:
991 * Some object may, when copied, loose their type, i.e. will become
992 * just plain string objects.
993 *
994 *-----------------------------------------------------------------------------
995 */
996
997 Tcl_Obj *
Sv_DuplicateObj(Tcl_Obj * objPtr)998 Sv_DuplicateObj(
999 Tcl_Obj *objPtr /* The object to duplicate. */
1000 ) {
1001 Tcl_Obj *dupPtr = Tcl_NewObj();
1002
1003 /*
1004 * Handle the internal rep
1005 */
1006
1007 if (objPtr->typePtr != NULL) {
1008 if (objPtr->typePtr->dupIntRepProc == NULL) {
1009 dupPtr->internalRep = objPtr->internalRep;
1010 dupPtr->typePtr = objPtr->typePtr;
1011 Tcl_InvalidateStringRep(dupPtr);
1012 } else {
1013 if ( objPtr->typePtr == booleanObjTypePtr \
1014 || objPtr->typePtr == byteArrayObjTypePtr \
1015 || objPtr->typePtr == doubleObjTypePtr \
1016 || objPtr->typePtr == intObjTypePtr \
1017 || objPtr->typePtr == wideIntObjTypePtr \
1018 || objPtr->typePtr == stringObjTypePtr) {
1019 /*
1020 * Cover all "safe" obj types (see header comment)
1021 */
1022 (*objPtr->typePtr->dupIntRepProc)(objPtr, dupPtr);
1023 Tcl_InvalidateStringRep(dupPtr);
1024 } else {
1025 int found = 0;
1026 RegType *regPtr;
1027 /*
1028 * Cover special registered types. Assume not
1029 * very many of those, so this sequential walk
1030 * should be fast enough.
1031 */
1032 for (regPtr = regType; regPtr; regPtr = regPtr->nextPtr) {
1033 if (objPtr->typePtr == regPtr->typePtr) {
1034 (*regPtr->dupIntRepProc)(objPtr, dupPtr);
1035 Tcl_InvalidateStringRep(dupPtr);
1036 found = 1;
1037 break;
1038 }
1039 }
1040 /*
1041 * Assure at least string rep of the source
1042 * is present, which will be copied below.
1043 */
1044 if (found == 0 && objPtr->bytes == NULL
1045 && objPtr->typePtr->updateStringProc != NULL) {
1046 (*objPtr->typePtr->updateStringProc)(objPtr);
1047 }
1048 }
1049 }
1050 }
1051
1052 /*
1053 * Handle the string rep
1054 */
1055
1056 if (objPtr->bytes == NULL) {
1057 dupPtr->bytes = NULL;
1058 } else if (objPtr->bytes != Sv_tclEmptyStringRep) {
1059 /* A copy of TclInitStringRep macro */
1060 dupPtr->bytes = (char*)ckalloc((unsigned)objPtr->length + 1);
1061 if (objPtr->length > 0) {
1062 memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
1063 (unsigned)objPtr->length);
1064 }
1065 dupPtr->length = objPtr->length;
1066 dupPtr->bytes[objPtr->length] = '\0';
1067 }
1068
1069 return dupPtr;
1070 }
1071
1072 /*
1073 *-----------------------------------------------------------------------------
1074 *
1075 * SvObjDispatchObjCmd --
1076 *
1077 * The method command for dispatching sub-commands of the shared
1078 * object.
1079 *
1080 * Results:
1081 * A standard Tcl result.
1082 *
1083 * Side effects:
1084 * Depends on the dispatched command
1085 *
1086 *-----------------------------------------------------------------------------
1087 */
1088
1089 static int
SvObjDispatchObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1090 SvObjDispatchObjCmd(
1091 ClientData arg, /* Pointer to object container. */
1092 Tcl_Interp *interp, /* Current interpreter. */
1093 int objc, /* Number of arguments. */
1094 Tcl_Obj *const objv[]) /* Argument objects. */
1095 {
1096 const char *cmdName;
1097 SvCmdInfo *cmdPtr;
1098
1099 if (objc < 2) {
1100 Tcl_WrongNumArgs(interp, 1, objv, "args");
1101 return TCL_ERROR;
1102 }
1103
1104 cmdName = Tcl_GetString(objv[1]);
1105
1106 /*
1107 * Do simple linear search. We may later replace this list
1108 * with the hash table to gain speed. Currently, the list
1109 * of registered commands is so small, so this will work
1110 * fast enough.
1111 */
1112
1113 for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
1114 if (!strcmp(cmdPtr->name, cmdName)) {
1115 return (*cmdPtr->objProcPtr)(arg, interp, objc, objv);
1116 }
1117 }
1118
1119 Tcl_AppendResult(interp, "invalid command name \"", cmdName, "\"", NULL);
1120 return TCL_ERROR;
1121 }
1122
1123 /*
1124 *-----------------------------------------------------------------------------
1125 *
1126 * SvObjObjCmd --
1127 *
1128 * Creates the object command for a shared array.
1129 *
1130 * Results:
1131 * A standard Tcl result.
1132 *
1133 * Side effects:
1134 * New Tcl command gets created.
1135 *
1136 *-----------------------------------------------------------------------------
1137 */
1138
1139 static int
SvObjObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1140 SvObjObjCmd(
1141 ClientData arg, /* != NULL if aolSpecial */
1142 Tcl_Interp *interp, /* Current interpreter. */
1143 int objc, /* Number of arguments. */
1144 Tcl_Obj *const objv[]) /* Argument objects. */
1145 {
1146 int isNew, off, ret, flg;
1147 char buf[128];
1148 Tcl_Obj *val = NULL;
1149 Container *svObj = NULL;
1150
1151 /*
1152 * Syntax: sv::object array key ?var?
1153 */
1154
1155 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1156 switch (ret) {
1157 case TCL_BREAK: /* Shared array was not found */
1158 if ((objc - off)) {
1159 val = objv[off];
1160 }
1161 Tcl_ResetResult(interp);
1162 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
1163 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
1164 if (ret != TCL_OK) {
1165 return TCL_ERROR;
1166 }
1167 Tcl_DecrRefCount(svObj->tclObj);
1168 svObj->tclObj = Sv_DuplicateObj(val ? val : Tcl_NewObj());
1169 Tcl_IncrRefCount(svObj->tclObj);
1170 break;
1171 case TCL_ERROR:
1172 return TCL_ERROR;
1173 }
1174
1175 if (svObj->handlePtr == NULL) {
1176 Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles;
1177 svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &isNew);
1178 }
1179
1180 /*
1181 * Format the command name
1182 */
1183
1184 sprintf(buf, "::%p", (int*)svObj);
1185 svObj->aolSpecial = (arg != NULL);
1186 Tcl_CreateObjCommand(interp, buf, SvObjDispatchObjCmd, svObj, NULL);
1187 Tcl_ResetResult(interp);
1188 Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
1189
1190 return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
1191 }
1192
1193 /*
1194 *-----------------------------------------------------------------------------
1195 *
1196 * SvArrayObjCmd --
1197 *
1198 * This procedure is invoked to process the "tsv::array" command.
1199 * See the user documentation for details on what it does.
1200 *
1201 * Results:
1202 * A standard Tcl result.
1203 *
1204 * Side effects:
1205 * See the user documentation.
1206 *
1207 *-----------------------------------------------------------------------------
1208 */
1209
1210 static int
SvArrayObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1211 SvArrayObjCmd(
1212 ClientData arg, /* Pointer to object container. */
1213 Tcl_Interp *interp, /* Current interpreter. */
1214 int objc, /* Number of arguments. */
1215 Tcl_Obj *const objv[]) /* Argument objects. */
1216 {
1217 int i, argx = 0, lobjc = 0, index, ret = TCL_OK;
1218 const char *arrayName = NULL;
1219 Array *arrayPtr = NULL;
1220 Tcl_Obj **lobjv = NULL;
1221 Container *svObj, *elObj = NULL;
1222
1223 static const char *opts[] = {
1224 "set", "reset", "get", "names", "size", "exists", "isbound",
1225 "bind", "unbind", NULL
1226 };
1227 enum options {
1228 ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND,
1229 ABIND, AUNBIND
1230 };
1231
1232 svObj = (Container*)arg;
1233
1234 if (objc < 3) {
1235 Tcl_WrongNumArgs(interp, 1, objv, "option array");
1236 return TCL_ERROR;
1237 }
1238
1239 arrayName = Tcl_GetString(objv[2]);
1240 arrayPtr = LockArray(interp, arrayName, FLAGS_NOERRMSG);
1241
1242 if (objc > 3) {
1243 argx = 3;
1244 }
1245
1246 Tcl_ResetResult(interp);
1247
1248 if (Tcl_GetIndexFromObjStruct(interp,objv[1],opts, sizeof(char *),"option",0,&index) != TCL_OK) {
1249 ret = TCL_ERROR;
1250
1251 } else if (index == AEXISTS) {
1252 Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr!=0);
1253
1254 } else if (index == AISBOUND) {
1255 if (arrayPtr == NULL) {
1256 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1257 } else {
1258 Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr->psPtr!=0);
1259 }
1260
1261 } else if (index == ASIZE) {
1262 if (arrayPtr == NULL) {
1263 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1264 } else {
1265 Tcl_SetWideIntObj(Tcl_GetObjResult(interp),arrayPtr->vars.numEntries);
1266 }
1267
1268 } else if (index == ASET || index == ARESET) {
1269 if (argx == (objc - 1)) {
1270 if (argx && Tcl_ListObjGetElements(interp, objv[argx], &lobjc,
1271 &lobjv) != TCL_OK) {
1272 ret = TCL_ERROR;
1273 goto cmdExit;
1274 }
1275 } else {
1276 lobjc = objc - 3;
1277 lobjv = (Tcl_Obj**)objv + 3;
1278 }
1279 if (lobjc & 1) {
1280 Tcl_AppendResult(interp, "list must have an even number"
1281 " of elements", NULL);
1282 ret = TCL_ERROR;
1283 goto cmdExit;
1284 }
1285 if (arrayPtr == NULL) {
1286 arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
1287 }
1288 if (index == ARESET) {
1289 ret = FlushArray(arrayPtr);
1290 if (ret != TCL_OK) {
1291 if (arrayPtr->psPtr) {
1292 PsStore *psPtr = arrayPtr->psPtr;
1293 const char *err = psPtr->psError(psPtr->psHandle);
1294 Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
1295 }
1296 goto cmdExit;
1297 }
1298 }
1299 for (i = 0; i < lobjc; i += 2) {
1300 const char *key = Tcl_GetString(lobjv[i]);
1301 elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);
1302 Tcl_DecrRefCount(elObj->tclObj);
1303 elObj->tclObj = Sv_DuplicateObj(lobjv[i+1]);
1304 Tcl_IncrRefCount(elObj->tclObj);
1305 if (ReleaseContainer(interp, elObj, SV_CHANGED) != TCL_OK) {
1306 ret = TCL_ERROR;
1307 goto cmdExit;
1308 }
1309 }
1310
1311 } else if (index == AGET || index == ANAMES) {
1312 if (arrayPtr) {
1313 Tcl_HashSearch search;
1314 Tcl_Obj *resObj = Tcl_NewListObj(0, NULL);
1315 const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]);
1316 Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
1317 while (hPtr) {
1318 char *key = (char *)Tcl_GetHashKey(&arrayPtr->vars, hPtr);
1319 if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) {
1320 Tcl_ListObjAppendElement(interp, resObj,
1321 Tcl_NewStringObj(key, -1));
1322 if (index == AGET) {
1323 elObj = (Container*)Tcl_GetHashValue(hPtr);
1324 Tcl_ListObjAppendElement(interp, resObj,
1325 Sv_DuplicateObj(elObj->tclObj));
1326 }
1327 }
1328 hPtr = Tcl_NextHashEntry(&search);
1329 }
1330 Tcl_SetObjResult(interp, resObj);
1331 }
1332
1333 } else if (index == ABIND) {
1334
1335 /*
1336 * This is more complex operation, requiring some clarification.
1337 *
1338 * When binding an already existing array, we walk the array
1339 * first and store all key/value pairs found there in the
1340 * persistent storage. Then we proceed with the below.
1341 *
1342 * When binding an non-existent array, we open the persistent
1343 * storage and cache all key/value pairs found there into tne
1344 * newly created shared array.
1345 */
1346
1347 PsStore *psPtr;
1348 Tcl_HashEntry *hPtr;
1349 size_t len;
1350 int isNew;
1351 char *psurl, *key = NULL, *val = NULL;
1352
1353 if (objc < 4) {
1354 Tcl_WrongNumArgs(interp, 2, objv, "array handle");
1355 ret = TCL_ERROR;
1356 goto cmdExit;
1357 }
1358
1359 if (arrayPtr && arrayPtr->psPtr) {
1360 Tcl_AppendResult(interp, "array is already bound", NULL);
1361 ret = TCL_ERROR;
1362 goto cmdExit;
1363 }
1364
1365 psurl = Tcl_GetString(objv[3]);
1366 len = objv[3]->length;
1367 psPtr = GetPsStore(psurl);
1368
1369 if (psPtr == NULL) {
1370 Tcl_AppendResult(interp, "can't open persistent storage on \"",
1371 psurl, "\"", NULL);
1372 ret = TCL_ERROR;
1373 goto cmdExit;
1374 }
1375 if (arrayPtr) {
1376 Tcl_HashSearch search;
1377 hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
1378 arrayPtr->psPtr = psPtr;
1379 arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl);
1380 while (hPtr) {
1381 svObj = (Container *)Tcl_GetHashValue(hPtr);
1382 if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
1383 ret = TCL_ERROR;
1384 goto cmdExit;
1385 }
1386 hPtr = Tcl_NextHashEntry(&search);
1387 }
1388 } else {
1389 arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
1390 arrayPtr->psPtr = psPtr;
1391 arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl);
1392 }
1393 if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) {
1394 do {
1395 Tcl_Obj * tclObj = Tcl_NewStringObj(val, len);
1396 hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew);
1397 Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
1398 psPtr->psFree(psPtr->psHandle, val);
1399 } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len));
1400 }
1401
1402 } else if (index == AUNBIND) {
1403 if (!arrayPtr || !arrayPtr->psPtr) {
1404 Tcl_AppendResult(interp, "shared variable is not bound", NULL);
1405 ret = TCL_ERROR;
1406 goto cmdExit;
1407 }
1408 if (UnbindArray(interp, arrayPtr) != TCL_OK) {
1409 ret = TCL_ERROR;
1410 goto cmdExit;
1411 }
1412 }
1413
1414 cmdExit:
1415 if (arrayPtr) {
1416 UnlockArray(arrayPtr);
1417 }
1418
1419 return ret;
1420 }
1421
1422 /*
1423 *-----------------------------------------------------------------------------
1424 *
1425 * SvUnsetObjCmd --
1426 *
1427 * This procedure is invoked to process the "tsv::unset" command.
1428 * See the user documentation for details on what it does.
1429 *
1430 * Results:
1431 * A standard Tcl result.
1432 *
1433 * Side effects:
1434 * See the user documentation.
1435 *
1436 *-----------------------------------------------------------------------------
1437 */
1438
1439 static int
SvUnsetObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1440 SvUnsetObjCmd(
1441 ClientData dummy, /* Not used. */
1442 Tcl_Interp *interp, /* Current interpreter. */
1443 int objc, /* Number of arguments. */
1444 Tcl_Obj *const objv[]) /* Argument objects. */
1445 {
1446 int ii;
1447 const char *arrayName;
1448 Array *arrayPtr;
1449 (void)dummy;
1450
1451 if (objc < 2) {
1452 Tcl_WrongNumArgs(interp, 1, objv, "array ?key ...?");
1453 return TCL_ERROR;
1454 }
1455
1456 arrayName = Tcl_GetString(objv[1]);
1457 arrayPtr = LockArray(interp, arrayName, 0);
1458
1459 if (arrayPtr == NULL) {
1460 return TCL_ERROR;
1461 }
1462 if (objc == 2) {
1463 UnlockArray(arrayPtr);
1464 if (DeleteArray(interp, arrayPtr) != TCL_OK) {
1465 return TCL_ERROR;
1466 }
1467 } else {
1468 for (ii = 2; ii < objc; ii++) {
1469 const char *key = Tcl_GetString(objv[ii]);
1470 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
1471 if (hPtr) {
1472 if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr))
1473 != TCL_OK) {
1474 UnlockArray(arrayPtr);
1475 return TCL_ERROR;
1476 }
1477 } else {
1478 UnlockArray(arrayPtr);
1479 Tcl_AppendResult(interp,"no key ",arrayName,"(",key,")",NULL);
1480 return TCL_ERROR;
1481 }
1482 }
1483 UnlockArray(arrayPtr);
1484 }
1485
1486 return TCL_OK;
1487 }
1488
1489 /*
1490 *-----------------------------------------------------------------------------
1491 *
1492 * SvNamesObjCmd --
1493 *
1494 * This procedure is invoked to process the "tsv::names" command.
1495 * See the user documentation for details on what it does.
1496 *
1497 * Results:
1498 * A standard Tcl result.
1499 *
1500 * Side effects:
1501 * See the user documentation.
1502 *
1503 *-----------------------------------------------------------------------------
1504 */
1505
1506 static int
SvNamesObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1507 SvNamesObjCmd(
1508 ClientData arg, /* != NULL if aolSpecial */
1509 Tcl_Interp *interp, /* Current interpreter. */
1510 int objc, /* Number of arguments. */
1511 Tcl_Obj *const objv[]) /* Argument objects. */
1512 {
1513 int i;
1514 const char *pattern = NULL;
1515 Tcl_HashEntry *hPtr;
1516 Tcl_HashSearch search;
1517 Tcl_Obj *resObj;
1518
1519 if (objc > 2) {
1520 Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
1521 return TCL_ERROR;
1522 }
1523 if (objc == 2) {
1524 pattern = Tcl_GetString(objv[1]);
1525 }
1526
1527 resObj = Tcl_NewListObj(0, NULL);
1528
1529 for (i = 0; i < NUMBUCKETS; i++) {
1530 Bucket *bucketPtr = &buckets[i];
1531 LOCK_BUCKET(bucketPtr);
1532 hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
1533 while (hPtr) {
1534 char *key = (char *)Tcl_GetHashKey(&bucketPtr->arrays, hPtr);
1535 if ((arg==NULL || (*key != '.')) /* Hide .<name> arrays for AOL*/ &&
1536 (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0))) {
1537 Tcl_ListObjAppendElement(interp, resObj,
1538 Tcl_NewStringObj(key, -1));
1539 }
1540 hPtr = Tcl_NextHashEntry(&search);
1541 }
1542 UNLOCK_BUCKET(bucketPtr);
1543 }
1544
1545 Tcl_SetObjResult(interp, resObj);
1546
1547 return TCL_OK;
1548 }
1549
1550 /*
1551 *-----------------------------------------------------------------------------
1552 *
1553 * SvGetObjCmd --
1554 *
1555 * This procedure is invoked to process "tsv::get" command.
1556 * See the user documentation for details on what it does.
1557 *
1558 * Results:
1559 * A standard Tcl result.
1560 *
1561 * Side effects:
1562 * See the user documentation.
1563 *
1564 *-----------------------------------------------------------------------------
1565 */
1566
1567 static int
SvGetObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1568 SvGetObjCmd(
1569 ClientData arg, /* Pointer to object container. */
1570 Tcl_Interp *interp, /* Current interpreter. */
1571 int objc, /* Number of arguments. */
1572 Tcl_Obj *const objv[]) /* Argument objects. */
1573 {
1574 int off, ret;
1575 Tcl_Obj *res;
1576 Container *svObj = (Container*)arg;
1577
1578 /*
1579 * Syntax:
1580 * tsv::get array key ?var?
1581 * $object get ?var?
1582 */
1583
1584 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1585 switch (ret) {
1586 case TCL_BREAK:
1587 if ((objc - off) == 0) {
1588 return TCL_ERROR;
1589 } else {
1590 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
1591 return TCL_OK;
1592 }
1593 case TCL_ERROR:
1594 return TCL_ERROR;
1595 }
1596
1597 res = Sv_DuplicateObj(svObj->tclObj);
1598
1599 if ((objc - off) == 0) {
1600 Tcl_SetObjResult(interp, res);
1601 } else {
1602 if (Tcl_ObjSetVar2(interp, objv[off], NULL, res, 0) == NULL) {
1603 Tcl_DecrRefCount(res);
1604 goto cmd_err;
1605 }
1606 Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
1607 }
1608
1609 return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
1610
1611 cmd_err:
1612 return Sv_PutContainer(interp, svObj, SV_ERROR);
1613 }
1614
1615 /*
1616 *-----------------------------------------------------------------------------
1617 *
1618 * SvExistsObjCmd --
1619 *
1620 * This procedure is invoked to process "tsv::exists" command.
1621 * See the user documentation for details on what it does.
1622 *
1623 * Results:
1624 * A standard Tcl result.
1625 *
1626 * Side effects:
1627 * See the user documentation.
1628 *
1629 *-----------------------------------------------------------------------------
1630 */
1631
1632 static int
SvExistsObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1633 SvExistsObjCmd(
1634 ClientData arg, /* Pointer to object container. */
1635 Tcl_Interp *interp, /* Current interpreter. */
1636 int objc, /* Number of arguments. */
1637 Tcl_Obj *const objv[]) /* Argument objects. */
1638 {
1639 int off, ret;
1640 Container *svObj = (Container*)arg;
1641
1642 /*
1643 * Syntax:
1644 * tsv::exists array key
1645 * $object exists
1646 */
1647
1648 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1649 switch (ret) {
1650 case TCL_BREAK: /* Array/key not found */
1651 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
1652 return TCL_OK;
1653 case TCL_ERROR:
1654 return TCL_ERROR;
1655 }
1656
1657 Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
1658
1659 return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
1660 }
1661
1662 /*
1663 *-----------------------------------------------------------------------------
1664 *
1665 * SvSetObjCmd --
1666 *
1667 * This procedure is invoked to process the "tsv::set" command.
1668 * See the user documentation for details on what it does.
1669 *
1670 * Results:
1671 * A standard Tcl result.
1672 *
1673 * Side effects:
1674 * See the user documentation.
1675 *
1676 *-----------------------------------------------------------------------------
1677 */
1678
1679 static int
SvSetObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1680 SvSetObjCmd(
1681 ClientData arg, /* Pointer to object container */
1682 Tcl_Interp *interp, /* Current interpreter. */
1683 int objc, /* Number of arguments. */
1684 Tcl_Obj *const objv[]) /* Argument objects. */
1685 {
1686 int ret, off, flg, mode;
1687 Tcl_Obj *val;
1688 Container *svObj = (Container*)arg;
1689
1690 /*
1691 * Syntax:
1692 * tsv::set array key ?value?
1693 * $object set ?value?
1694 */
1695
1696 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1697 switch (ret) {
1698 case TCL_BREAK:
1699 if ((objc - off) == 0) {
1700 return TCL_ERROR;
1701 } else {
1702 Tcl_ResetResult(interp);
1703 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
1704 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
1705 if (ret != TCL_OK) {
1706 return TCL_ERROR;
1707 }
1708 }
1709 break;
1710 case TCL_ERROR:
1711 return TCL_ERROR;
1712 }
1713 if ((objc - off)) {
1714 val = objv[off];
1715 Tcl_DecrRefCount(svObj->tclObj);
1716 svObj->tclObj = Sv_DuplicateObj(val);
1717 Tcl_IncrRefCount(svObj->tclObj);
1718 mode = SV_CHANGED;
1719 } else {
1720 val = Sv_DuplicateObj(svObj->tclObj);
1721 mode = SV_UNCHANGED;
1722 }
1723
1724 Tcl_SetObjResult(interp, val);
1725
1726 return Sv_PutContainer(interp, svObj, mode);
1727 }
1728
1729 /*
1730 *-----------------------------------------------------------------------------
1731 *
1732 * SvIncrObjCmd --
1733 *
1734 * This procedure is invoked to process the "tsv::incr" command.
1735 * See the user documentation for details on what it does.
1736 *
1737 * Results:
1738 * A standard Tcl result.
1739 *
1740 * Side effects:
1741 * See the user documentation.
1742 *
1743 *-----------------------------------------------------------------------------
1744 */
1745
1746 static int
SvIncrObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1747 SvIncrObjCmd(
1748 ClientData arg, /* Pointer to object container */
1749 Tcl_Interp *interp, /* Current interpreter. */
1750 int objc, /* Number of arguments. */
1751 Tcl_Obj *const objv[]) /* Argument objects. */
1752 {
1753 int off, ret, flg, isNew = 0;
1754 Tcl_WideInt incrValue = 1, currValue = 0;
1755 Container *svObj = (Container*)arg;
1756
1757 /*
1758 * Syntax:
1759 * tsv::incr array key ?increment?
1760 * $object incr ?increment?
1761 */
1762
1763 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1764 if (ret != TCL_OK) {
1765 if (ret != TCL_BREAK) {
1766 return TCL_ERROR;
1767 }
1768 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
1769 Tcl_ResetResult(interp);
1770 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
1771 if (ret != TCL_OK) {
1772 return TCL_ERROR;
1773 }
1774 isNew = 1;
1775 }
1776 if ((objc - off)) {
1777 ret = Tcl_GetWideIntFromObj(interp, objv[off], &incrValue);
1778 if (ret != TCL_OK) {
1779 goto cmd_err;
1780 }
1781 }
1782 if (isNew) {
1783 currValue = 0;
1784 } else {
1785 ret = Tcl_GetWideIntFromObj(interp, svObj->tclObj, &currValue);
1786 if (ret != TCL_OK) {
1787 goto cmd_err;
1788 }
1789 }
1790
1791 incrValue += currValue;
1792 Tcl_SetWideIntObj(svObj->tclObj, incrValue);
1793 Tcl_ResetResult(interp);
1794 Tcl_SetWideIntObj(Tcl_GetObjResult(interp), incrValue);
1795
1796 return Sv_PutContainer(interp, svObj, SV_CHANGED);
1797
1798 cmd_err:
1799 return Sv_PutContainer(interp, svObj, SV_ERROR);
1800 }
1801
1802 /*
1803 *-----------------------------------------------------------------------------
1804 *
1805 * SvAppendObjCmd --
1806 *
1807 * This procedure is invoked to process the "tsv::append" command.
1808 * See the user documentation for details on what it does.
1809 *
1810 * Results:
1811 * A standard Tcl result.
1812 *
1813 * Side effects:
1814 * See the user documentation.
1815 *
1816 *-----------------------------------------------------------------------------
1817 */
1818
1819 static int
SvAppendObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1820 SvAppendObjCmd(
1821 ClientData arg, /* Pointer to object container */
1822 Tcl_Interp *interp, /* Current interpreter. */
1823 int objc, /* Number of arguments. */
1824 Tcl_Obj *const objv[]) /* Argument objects. */
1825 {
1826 int i, off, flg, ret;
1827 Container *svObj = (Container*)arg;
1828
1829 /*
1830 * Syntax:
1831 * tsv::append array key value ?value ...?
1832 * $object append value ?value ...?
1833 */
1834
1835 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
1836 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
1837 if (ret != TCL_OK) {
1838 return TCL_ERROR;
1839 }
1840 if ((objc - off) < 1) {
1841 Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?");
1842 goto cmd_err;
1843 }
1844 for (i = off; i < objc; ++i) {
1845 Tcl_AppendObjToObj(svObj->tclObj, Sv_DuplicateObj(objv[i]));
1846 }
1847
1848 Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj));
1849
1850 return Sv_PutContainer(interp, svObj, SV_CHANGED);
1851
1852 cmd_err:
1853 return Sv_PutContainer(interp, svObj, SV_ERROR);
1854 }
1855
1856 /*
1857 *-----------------------------------------------------------------------------
1858 *
1859 * SvPopObjCmd --
1860 *
1861 * This procedure is invoked to process "tsv::pop" command.
1862 * See the user documentation for details on what it does.
1863 *
1864 * Results:
1865 * A standard Tcl result.
1866 *
1867 * Side effects:
1868 * See the user documentation.
1869 *
1870 *-----------------------------------------------------------------------------
1871 */
1872
1873 static int
SvPopObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1874 SvPopObjCmd(
1875 ClientData arg, /* Pointer to object container */
1876 Tcl_Interp *interp, /* Current interpreter. */
1877 int objc, /* Number of arguments. */
1878 Tcl_Obj *const objv[]) /* Argument objects. */
1879 {
1880 int ret, off;
1881 Tcl_Obj *retObj;
1882 Array *arrayPtr = NULL;
1883 Container *svObj = (Container*)arg;
1884
1885 /*
1886 * Syntax:
1887 * tsv::pop array key ?var?
1888 * $object pop ?var?
1889 *
1890 * Note: the object command will run into error next time !
1891 */
1892
1893 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1894 switch (ret) {
1895 case TCL_BREAK:
1896 if ((objc - off) == 0) {
1897 return TCL_ERROR;
1898 } else {
1899 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
1900 return TCL_OK;
1901 }
1902 case TCL_ERROR:
1903 return TCL_ERROR;
1904 }
1905
1906 arrayPtr = svObj->arrayPtr;
1907
1908 retObj = svObj->tclObj;
1909 svObj->tclObj = NULL;
1910
1911 if (DeleteContainer(svObj) != TCL_OK) {
1912 if (svObj->arrayPtr->psPtr) {
1913 PsStore *psPtr = svObj->arrayPtr->psPtr;
1914 const char *err = psPtr->psError(psPtr->psHandle);
1915 Tcl_SetObjResult(interp, Tcl_NewStringObj(err,-1));
1916 }
1917 ret = TCL_ERROR;
1918 goto cmd_exit;
1919 }
1920
1921 if ((objc - off) == 0) {
1922 Tcl_SetObjResult(interp, retObj);
1923 } else {
1924 if (Tcl_ObjSetVar2(interp, objv[off], NULL, retObj, 0) == NULL) {
1925 ret = TCL_ERROR;
1926 goto cmd_exit;
1927 }
1928 Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
1929 }
1930
1931 cmd_exit:
1932 Tcl_DecrRefCount(retObj);
1933 UnlockArray(arrayPtr);
1934
1935 return ret;
1936 }
1937
1938 /*
1939 *-----------------------------------------------------------------------------
1940 *
1941 * SvMoveObjCmd --
1942 *
1943 * This procedure is invoked to process the "tsv::move" command.
1944 * See the user documentation for details on what it does.
1945 *
1946 *
1947 * Results:
1948 * A standard Tcl result.
1949 *
1950 * Side effects:
1951 * See the user documentation.
1952 *
1953 *-----------------------------------------------------------------------------
1954 */
1955
1956 static int
SvMoveObjCmd(ClientData arg,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1957 SvMoveObjCmd(
1958 ClientData arg, /* Pointer to object container. */
1959 Tcl_Interp *interp, /* Current interpreter. */
1960 int objc, /* Number of arguments. */
1961 Tcl_Obj *const objv[]) /* Argument objects. */
1962 {
1963 int ret, off, isNew;
1964 const char *toKey;
1965 Tcl_HashEntry *hPtr;
1966 Container *svObj = (Container*)arg;
1967
1968 /*
1969 * Syntax:
1970 * tsv::move array key to
1971 * $object move to
1972 */
1973
1974 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
1975 if (ret != TCL_OK) {
1976 return TCL_ERROR;
1977 }
1978
1979 toKey = Tcl_GetString(objv[off]);
1980 hPtr = Tcl_CreateHashEntry(&svObj->arrayPtr->vars, toKey, &isNew);
1981
1982 if (!isNew) {
1983 Tcl_AppendResult(interp, "key \"", toKey, "\" exists", NULL);
1984 goto cmd_err;
1985 }
1986 if (svObj->entryPtr) {
1987 char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
1988 if (svObj->arrayPtr->psPtr) {
1989 PsStore *psPtr = svObj->arrayPtr->psPtr;
1990 if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
1991 const char *err = psPtr->psError(psPtr->psHandle);
1992 Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
1993 return TCL_ERROR;
1994 }
1995 }
1996 Tcl_DeleteHashEntry(svObj->entryPtr);
1997 }
1998
1999 svObj->entryPtr = hPtr;
2000 Tcl_SetHashValue(hPtr, svObj);
2001
2002 return Sv_PutContainer(interp, svObj, SV_CHANGED);
2003
2004 cmd_err:
2005 return Sv_PutContainer(interp, svObj, SV_ERROR);
2006
2007 }
2008
2009 /*
2010 *----------------------------------------------------------------------
2011 *
2012 * SvLockObjCmd --
2013 *
2014 * This procedure is invoked to process "tsv::lock" Tcl command.
2015 * See the user documentation for details on what it does.
2016 *
2017 * Results:
2018 * A standard Tcl result.
2019 *
2020 * Side effects:
2021 * See the user documentation.
2022 *
2023 *----------------------------------------------------------------------
2024 */
2025
2026 static int
SvLockObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2027 SvLockObjCmd(
2028 ClientData dummy, /* Not used. */
2029 Tcl_Interp *interp, /* Current interpreter. */
2030 int objc, /* Number of arguments. */
2031 Tcl_Obj *const objv[]) /* Argument objects. */
2032 {
2033 int ret;
2034 Tcl_Obj *scriptObj;
2035 Bucket *bucketPtr;
2036 Array *arrayPtr = NULL;
2037 (void)dummy;
2038
2039 /*
2040 * Syntax:
2041 *
2042 * tsv::lock array arg ?arg ...?
2043 */
2044
2045 if (objc < 3) {
2046 Tcl_WrongNumArgs(interp, 1, objv, "array arg ?arg...?");
2047 return TCL_ERROR;
2048 }
2049
2050 arrayPtr = LockArray(interp, Tcl_GetString(objv[1]), FLAGS_CREATEARRAY);
2051 bucketPtr = arrayPtr->bucketPtr;
2052
2053 /*
2054 * Evaluate passed arguments as Tcl script. Note that
2055 * Tcl_EvalObjEx throws away the passed object by
2056 * doing an decrement reference count on it. This also
2057 * means we need not build object bytecode rep.
2058 */
2059
2060 if (objc == 3) {
2061 scriptObj = Tcl_DuplicateObj(objv[2]);
2062 } else {
2063 scriptObj = Tcl_ConcatObj(objc-2, objv + 2);
2064 }
2065
2066 Tcl_AllowExceptions(interp);
2067 ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);
2068
2069 if (ret == TCL_ERROR) {
2070 char msg[32 + TCL_INTEGER_SPACE];
2071 /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
2072 * See Tcl bug #3562640 */
2073 sprintf(msg, "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
2074 Tcl_AddErrorInfo(interp, msg);
2075 }
2076
2077 /*
2078 * We unlock the bucket directly, w/o going to Sv_Unlock()
2079 * since it needs the array which may be unset by the script.
2080 */
2081
2082 UNLOCK_BUCKET(bucketPtr);
2083
2084 return ret;
2085 }
2086
2087 /*
2088 *-----------------------------------------------------------------------------
2089 *
2090 * SvHandlersObjCmd --
2091 *
2092 * This procedure is invoked to process "tsv::handlers" Tcl command.
2093 * See the user documentation for details on what it does.
2094 *
2095 * Results:
2096 * A standard Tcl result.
2097 *
2098 * Side effects:
2099 * None.
2100 *
2101 *-----------------------------------------------------------------------------
2102 */
2103 static int
SvHandlersObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2104 SvHandlersObjCmd(
2105 ClientData dummy, /* Not used. */
2106 Tcl_Interp *interp, /* Current interpreter. */
2107 int objc, /* Number of arguments. */
2108 Tcl_Obj *const objv[]) /* Argument objects. */
2109 {
2110 PsStore *tmpPtr = NULL;
2111 (void)dummy;
2112
2113 /*
2114 * Syntax:
2115 *
2116 * tsv::handlers
2117 */
2118
2119 if (objc != 1) {
2120 Tcl_WrongNumArgs(interp, 1, objv, NULL);
2121 return TCL_ERROR;
2122 }
2123
2124 Tcl_ResetResult(interp);
2125 Tcl_MutexLock(&svMutex);
2126 for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
2127 Tcl_AppendElement(interp, tmpPtr->type);
2128 }
2129 Tcl_MutexUnlock(&svMutex);
2130
2131 return TCL_OK;
2132 }
2133
2134
2135 /*
2136 *-----------------------------------------------------------------------------
2137 *
2138 * Sv_RegisterStdCommands --
2139 *
2140 * Register standard shared variable commands
2141 *
2142 * Results:
2143 * A standard Tcl result.
2144 *
2145 * Side effects:
2146 * Memory gets allocated
2147 *
2148 *-----------------------------------------------------------------------------
2149 */
2150
2151 static void
SvRegisterStdCommands(void)2152 SvRegisterStdCommands(void)
2153 {
2154 static int initialized = 0;
2155
2156 if (initialized == 0) {
2157 Tcl_MutexLock(&initMutex);
2158 if (initialized == 0) {
2159 Sv_RegisterCommand("var", SvObjObjCmd, NULL, 1);
2160 Sv_RegisterCommand("object", SvObjObjCmd, NULL, 1);
2161 Sv_RegisterCommand("set", SvSetObjCmd, NULL, 0);
2162 Sv_RegisterCommand("unset", SvUnsetObjCmd, NULL, 0);
2163 Sv_RegisterCommand("get", SvGetObjCmd, NULL, 0);
2164 Sv_RegisterCommand("incr", SvIncrObjCmd, NULL, 0);
2165 Sv_RegisterCommand("exists", SvExistsObjCmd, NULL, 0);
2166 Sv_RegisterCommand("append", SvAppendObjCmd, NULL, 0);
2167 Sv_RegisterCommand("array", SvArrayObjCmd, NULL, 0);
2168 Sv_RegisterCommand("names", SvNamesObjCmd, NULL, 0);
2169 Sv_RegisterCommand("pop", SvPopObjCmd, NULL, 0);
2170 Sv_RegisterCommand("move", SvMoveObjCmd, NULL, 0);
2171 Sv_RegisterCommand("lock", SvLockObjCmd, NULL, 0);
2172 Sv_RegisterCommand("handlers", SvHandlersObjCmd, NULL, 0);
2173 initialized = 1;
2174 }
2175 Tcl_MutexUnlock(&initMutex);
2176 }
2177 }
2178
2179 /*
2180 *-----------------------------------------------------------------------------
2181 *
2182 * SvInit --
2183 *
2184 * Creates commands in current interpreter.
2185 *
2186 * Results:
2187 * NULL
2188 *
2189 * Side effects
2190 * Many new command created in current interpreter. Global data
2191 * structures used by them initialized as well.
2192 *
2193 *-----------------------------------------------------------------------------
2194 */
2195 const char *
SvInit(Tcl_Interp * interp)2196 SvInit (
2197 Tcl_Interp *interp
2198 ) {
2199 int i;
2200 Bucket *bucketPtr;
2201 SvCmdInfo *cmdPtr;
2202 Tcl_Obj *obj;
2203
2204 #ifdef SV_FINALIZE
2205 /*
2206 * Create exit handler for this thread
2207 */
2208 Tcl_CreateThreadExitHandler(SvFinalize, NULL);
2209
2210 /*
2211 * Increment number of threads
2212 */
2213 Tcl_MutexLock(&nofThreadsMutex);
2214 ++nofThreads;
2215 Tcl_MutexUnlock(&nofThreadsMutex);
2216 #endif /* SV_FINALIZE */
2217
2218 /*
2219 * Add keyed-list datatype
2220 */
2221
2222 TclX_KeyedListInit(interp);
2223 Sv_RegisterKeylistCommands();
2224
2225 /*
2226 * Register standard (nsv_* compatible) and our
2227 * own extensive set of list manipulating commands
2228 */
2229
2230 SvRegisterStdCommands();
2231 Sv_RegisterListCommands();
2232
2233 /*
2234 * Get Tcl object types. These are used
2235 * in custom object duplicator function.
2236 */
2237
2238 obj = Tcl_NewStringObj("no", -1);
2239 Tcl_GetBooleanFromObj(NULL, obj, &i);
2240 booleanObjTypePtr = obj->typePtr;
2241
2242 #ifdef USE_TCL_STUBS
2243 if (Tcl_GetUnicodeFromObj)
2244 #endif
2245 {
2246 Tcl_GetUnicodeFromObj(obj, &i);
2247 stringObjTypePtr = obj->typePtr;
2248 }
2249 Tcl_GetByteArrayFromObj(obj, &i);
2250 byteArrayObjTypePtr = obj->typePtr;
2251 Tcl_DecrRefCount(obj);
2252
2253 obj = Tcl_NewDoubleObj(0.0);
2254 doubleObjTypePtr = obj->typePtr;
2255 Tcl_DecrRefCount(obj);
2256
2257 obj = Tcl_NewIntObj(0);
2258 intObjTypePtr = obj->typePtr;
2259 Tcl_DecrRefCount(obj);
2260
2261 obj = Tcl_NewWideIntObj(((Tcl_WideInt)1)<<35);
2262 wideIntObjTypePtr = obj->typePtr;
2263 Tcl_DecrRefCount(obj);
2264
2265 /*
2266 * Plug-in registered commands in current interpreter
2267 */
2268
2269 for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
2270 Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr,
2271 NULL, (Tcl_CmdDeleteProc*)0);
2272 #ifdef NS_AOLSERVER
2273 Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr,
2274 (ClientData)(size_t)cmdPtr->aolSpecial, (Tcl_CmdDeleteProc*)0);
2275 #endif
2276 }
2277
2278 /*
2279 * Create array of buckets and initialize each bucket
2280 */
2281
2282 if (buckets == NULL) {
2283 Tcl_MutexLock(&bucketsMutex);
2284 if (buckets == NULL) {
2285 buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS);
2286
2287 for (i = 0; i < NUMBUCKETS; ++i) {
2288 bucketPtr = &buckets[i];
2289 memset(bucketPtr, 0, sizeof(Bucket));
2290 Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
2291 Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS);
2292 }
2293
2294 /*
2295 * There is no other way to get Sv_tclEmptyStringRep
2296 * pointer value w/o this trick.
2297 */
2298
2299 {
2300 Tcl_Obj *dummy = Tcl_NewObj();
2301 Sv_tclEmptyStringRep = dummy->bytes;
2302 Tcl_DecrRefCount(dummy);
2303 }
2304
2305 /*
2306 * Register persistent store handlers
2307 */
2308 #ifdef HAVE_GDBM
2309 Sv_RegisterGdbmStore();
2310 #endif
2311 #ifdef HAVE_LMDB
2312 Sv_RegisterLmdbStore();
2313 #endif
2314 }
2315 Tcl_MutexUnlock(&bucketsMutex);
2316 }
2317
2318 return NULL;
2319 }
2320
2321 #ifdef SV_FINALIZE
2322 /*
2323 * Left for reference, but unused since multithreaded finalization is
2324 * unsolvable in the general case. Brave souls can revive this by
2325 * installing a late exit handler on Thread's behalf, bringing the
2326 * function back onto the Tcl_Finalize (but not Tcl_Exit) path.
2327 */
2328
2329 /*
2330 *-----------------------------------------------------------------------------
2331 *
2332 * SvFinalize --
2333 *
2334 * Unset all arrays and reclaim all buckets.
2335 *
2336 * Results:
2337 * None.
2338 *
2339 * Side effects
2340 * Memory gets reclaimed.
2341 *
2342 *-----------------------------------------------------------------------------
2343 */
2344
2345 static void
SvFinalize(ClientData dummy)2346 SvFinalize (ClientData dummy)
2347 {
2348 int i;
2349 SvCmdInfo *cmdPtr;
2350 RegType *regPtr;
2351
2352 Tcl_HashEntry *hashPtr;
2353 Tcl_HashSearch search;
2354 (void)dummy;
2355
2356 /*
2357 * Decrement number of threads. Proceed only if I was the last one. The
2358 * mutex is unlocked at the end of this function, so new threads that might
2359 * want to register in the meanwhile will find a clean environment when
2360 * they eventually succeed acquiring nofThreadsMutex.
2361 */
2362 Tcl_MutexLock(&nofThreadsMutex);
2363 if (nofThreads > 1)
2364 {
2365 goto done;
2366 }
2367
2368 /*
2369 * Reclaim memory for shared arrays
2370 */
2371
2372 if (buckets != NULL) {
2373 Tcl_MutexLock(&bucketsMutex);
2374 if (buckets != NULL) {
2375 for (i = 0; i < NUMBUCKETS; ++i) {
2376 Bucket *bucketPtr = &buckets[i];
2377 hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
2378 while (hashPtr != NULL) {
2379 Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr);
2380 UnlockArray(arrayPtr);
2381 /* unbind array before delete (avoid flush of persistent storage) */
2382 UnbindArray(NULL, arrayPtr);
2383 /* flush, delete etc. */
2384 DeleteArray(NULL, arrayPtr);
2385 hashPtr = Tcl_NextHashEntry(&search);
2386 }
2387 if (bucketPtr->lock) {
2388 Sp_RecursiveMutexFinalize(&bucketPtr->lock);
2389 }
2390 SvFinalizeContainers(bucketPtr);
2391 Tcl_DeleteHashTable(&bucketPtr->handles);
2392 Tcl_DeleteHashTable(&bucketPtr->arrays);
2393 }
2394 ckfree((char *)buckets), buckets = NULL;
2395 }
2396 buckets = NULL;
2397 Tcl_MutexUnlock(&bucketsMutex);
2398 }
2399
2400 Tcl_MutexLock(&svMutex);
2401
2402 /*
2403 * Reclaim memory for registered commands
2404 */
2405
2406 if (svCmdInfo != NULL) {
2407 cmdPtr = svCmdInfo;
2408 while (cmdPtr) {
2409 SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
2410 ckfree((char*)cmdPtr);
2411 cmdPtr = tmpPtr;
2412 }
2413 svCmdInfo = NULL;
2414 }
2415
2416 /*
2417 * Reclaim memory for registered object types
2418 */
2419
2420 if (regType != NULL) {
2421 regPtr = regType;
2422 while (regPtr) {
2423 RegType *tmpPtr = regPtr->nextPtr;
2424 ckfree((char*)regPtr);
2425 regPtr = tmpPtr;
2426 }
2427 regType = NULL;
2428 }
2429
2430 Tcl_MutexUnlock(&svMutex);
2431
2432 done:
2433 --nofThreads;
2434 Tcl_MutexUnlock(&nofThreadsMutex);
2435 }
2436 #endif /* SV_FINALIZE */
2437
2438 /* EOF $RCSfile: threadSvCmd.c,v $ */
2439
2440 /* Emacs Setup Variables */
2441 /* Local Variables: */
2442 /* mode: C */
2443 /* indent-tabs-mode: nil */
2444 /* c-basic-offset: 4 */
2445 /* End: */
2446
2447