/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (show annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclevent.c
File MIME type: text/plain
File size: 30630 byte(s)
Initial commit.
1 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclevent.c,v 1.1.1.1 2001/06/13 04:38:05 dtashley Exp $ */
2
3 /*
4 * tclEvent.c --
5 *
6 * This file implements some general event related interfaces including
7 * background errors, exit handlers, and the "vwait" and "update"
8 * command procedures.
9 *
10 * Copyright (c) 1990-1994 The Regents of the University of California.
11 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
12 *
13 * See the file "license.terms" for information on usage and redistribution
14 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 *
16 * RCS: @(#) $Id: tclevent.c,v 1.1.1.1 2001/06/13 04:38:05 dtashley Exp $
17 */
18
19 #include "tclInt.h"
20 #include "tclPort.h"
21
22 /*
23 * The data structure below is used to report background errors. One
24 * such structure is allocated for each error; it holds information
25 * about the interpreter and the error until bgerror can be invoked
26 * later as an idle handler.
27 */
28
29 typedef struct BgError {
30 Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
31 * means this error report has been cancelled
32 * (a previous report generated a break). */
33 char *errorMsg; /* Copy of the error message (the interp's
34 * result when the error occurred).
35 * Malloc-ed. */
36 char *errorInfo; /* Value of the errorInfo variable
37 * (malloc-ed). */
38 char *errorCode; /* Value of the errorCode variable
39 * (malloc-ed). */
40 struct BgError *nextPtr; /* Next in list of all pending error
41 * reports for this interpreter, or NULL
42 * for end of list. */
43 } BgError;
44
45 /*
46 * One of the structures below is associated with the "tclBgError"
47 * assoc data for each interpreter. It keeps track of the head and
48 * tail of the list of pending background errors for the interpreter.
49 */
50
51 typedef struct ErrAssocData {
52 BgError *firstBgPtr; /* First in list of all background errors
53 * waiting to be processed for this
54 * interpreter (NULL if none). */
55 BgError *lastBgPtr; /* Last in list of all background errors
56 * waiting to be processed for this
57 * interpreter (NULL if none). */
58 } ErrAssocData;
59
60 /*
61 * For each exit handler created with a call to Tcl_CreateExitHandler
62 * there is a structure of the following type:
63 */
64
65 typedef struct ExitHandler {
66 Tcl_ExitProc *proc; /* Procedure to call when process exits. */
67 ClientData clientData; /* One word of information to pass to proc. */
68 struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
69 * this application, or NULL for end of list. */
70 } ExitHandler;
71
72 /*
73 * There is both per-process and per-thread exit handlers.
74 * The first list is controlled by a mutex. The other is in
75 * thread local storage.
76 */
77
78 static ExitHandler *firstExitPtr = NULL;
79 /* First in list of all exit handlers for
80 * application. */
81 TCL_DECLARE_MUTEX(exitMutex)
82
83 /*
84 * This variable is set to 1 when Tcl_Finalize is called, and at the end of
85 * its work, it is reset to 0. The variable is checked by TclInExit() to
86 * allow different behavior for exit-time processing, e.g. in closing of
87 * files and pipes.
88 */
89
90 static int inFinalize = 0;
91 static int subsystemsInitialized = 0;
92
93 typedef struct ThreadSpecificData {
94 ExitHandler *firstExitPtr; /* First in list of all exit handlers for
95 * this thread. */
96 int inExit; /* True when this thread is exiting. This
97 * is used as a hack to decide to close
98 * the standard channels. */
99 Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
100 } ThreadSpecificData;
101 static Tcl_ThreadDataKey dataKey;
102
103 /*
104 * Prototypes for procedures referenced only in this file:
105 */
106
107 static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
108 Tcl_Interp *interp));
109 static void HandleBgErrors _ANSI_ARGS_((ClientData clientData));
110 static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
111 Tcl_Interp *interp, char *name1, char *name2,
112 int flags));
113
114 /*
115 *----------------------------------------------------------------------
116 *
117 * Tcl_BackgroundError --
118 *
119 * This procedure is invoked to handle errors that occur in Tcl
120 * commands that are invoked in "background" (e.g. from event or
121 * timer bindings).
122 *
123 * Results:
124 * None.
125 *
126 * Side effects:
127 * The command "bgerror" is invoked later as an idle handler to
128 * process the error, passing it the error message. If that fails,
129 * then an error message is output on stderr.
130 *
131 *----------------------------------------------------------------------
132 */
133
134 void
135 Tcl_BackgroundError(interp)
136 Tcl_Interp *interp; /* Interpreter in which an error has
137 * occurred. */
138 {
139 BgError *errPtr;
140 char *errResult, *varValue;
141 ErrAssocData *assocPtr;
142 int length;
143
144 /*
145 * The Tcl_AddErrorInfo call below (with an empty string) ensures that
146 * errorInfo gets properly set. It's needed in cases where the error
147 * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
148 * in these cases errorInfo still won't have been set when this
149 * procedure is called.
150 */
151
152 Tcl_AddErrorInfo(interp, "");
153
154 errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
155
156 errPtr = (BgError *) ckalloc(sizeof(BgError));
157 errPtr->interp = interp;
158 errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
159 memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
160 varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
161 if (varValue == NULL) {
162 varValue = errPtr->errorMsg;
163 }
164 errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
165 strcpy(errPtr->errorInfo, varValue);
166 varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
167 if (varValue == NULL) {
168 varValue = "";
169 }
170 errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
171 strcpy(errPtr->errorCode, varValue);
172 errPtr->nextPtr = NULL;
173
174 assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
175 (Tcl_InterpDeleteProc **) NULL);
176 if (assocPtr == NULL) {
177
178 /*
179 * This is the first time a background error has occurred in
180 * this interpreter. Create associated data to keep track of
181 * pending error reports.
182 */
183
184 assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
185 assocPtr->firstBgPtr = NULL;
186 assocPtr->lastBgPtr = NULL;
187 Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
188 (ClientData) assocPtr);
189 }
190 if (assocPtr->firstBgPtr == NULL) {
191 assocPtr->firstBgPtr = errPtr;
192 Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
193 } else {
194 assocPtr->lastBgPtr->nextPtr = errPtr;
195 }
196 assocPtr->lastBgPtr = errPtr;
197 Tcl_ResetResult(interp);
198 }
199
200 /*
201 *----------------------------------------------------------------------
202 *
203 * HandleBgErrors --
204 *
205 * This procedure is invoked as an idle handler to process all of
206 * the accumulated background errors.
207 *
208 * Results:
209 * None.
210 *
211 * Side effects:
212 * Depends on what actions "bgerror" takes for the errors.
213 *
214 *----------------------------------------------------------------------
215 */
216
217 static void
218 HandleBgErrors(clientData)
219 ClientData clientData; /* Pointer to ErrAssocData structure. */
220 {
221 Tcl_Interp *interp;
222 char *argv[2];
223 int code;
224 BgError *errPtr;
225 ErrAssocData *assocPtr = (ErrAssocData *) clientData;
226 Tcl_Channel errChannel;
227
228 Tcl_Preserve((ClientData) assocPtr);
229
230 while (assocPtr->firstBgPtr != NULL) {
231 interp = assocPtr->firstBgPtr->interp;
232 if (interp == NULL) {
233 goto doneWithInterp;
234 }
235
236 /*
237 * Restore important state variables to what they were at
238 * the time the error occurred.
239 */
240
241 Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
242 TCL_GLOBAL_ONLY);
243 Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
244 TCL_GLOBAL_ONLY);
245
246 /*
247 * Create and invoke the bgerror command.
248 */
249
250 argv[0] = "bgerror";
251 argv[1] = assocPtr->firstBgPtr->errorMsg;
252
253 Tcl_AllowExceptions(interp);
254 Tcl_Preserve((ClientData) interp);
255 code = TclGlobalInvoke(interp, 2, argv, 0);
256 if (code == TCL_ERROR) {
257
258 /*
259 * If the interpreter is safe, we look for a hidden command
260 * named "bgerror" and call that with the error information.
261 * Otherwise, simply ignore the error. The rationale is that
262 * this could be an error caused by a malicious applet trying
263 * to cause an infinite barrage of error messages. The hidden
264 * "bgerror" command can be used by a security policy to
265 * interpose on such attacks and e.g. kill the applet after a
266 * few attempts.
267 */
268
269 if (Tcl_IsSafe(interp)) {
270 Tcl_SavedResult save;
271
272 Tcl_SaveResult(interp, &save);
273 TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
274 Tcl_RestoreResult(interp, &save);
275
276 goto doneWithInterp;
277 }
278
279 /*
280 * We have to get the error output channel at the latest possible
281 * time, because the eval (above) might have changed the channel.
282 */
283
284 errChannel = Tcl_GetStdChannel(TCL_STDERR);
285 if (errChannel != (Tcl_Channel) NULL) {
286 char *string;
287 int len;
288
289 string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
290 if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {
291 Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
292 Tcl_WriteChars(errChannel, "\n", -1);
293 } else {
294 Tcl_WriteChars(errChannel,
295 "bgerror failed to handle background error.\n",
296 -1);
297 Tcl_WriteChars(errChannel, " Original error: ", -1);
298 Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
299 -1);
300 Tcl_WriteChars(errChannel, "\n", -1);
301 Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
302 Tcl_WriteChars(errChannel, string, len);
303 Tcl_WriteChars(errChannel, "\n", -1);
304 }
305 Tcl_Flush(errChannel);
306 }
307 } else if (code == TCL_BREAK) {
308
309 /*
310 * Break means cancel any remaining error reports for this
311 * interpreter.
312 */
313
314 for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
315 errPtr = errPtr->nextPtr) {
316 if (errPtr->interp == interp) {
317 errPtr->interp = NULL;
318 }
319 }
320 }
321
322 /*
323 * Discard the command and the information about the error report.
324 */
325
326 doneWithInterp:
327
328 if (assocPtr->firstBgPtr) {
329 ckfree(assocPtr->firstBgPtr->errorMsg);
330 ckfree(assocPtr->firstBgPtr->errorInfo);
331 ckfree(assocPtr->firstBgPtr->errorCode);
332 errPtr = assocPtr->firstBgPtr->nextPtr;
333 ckfree((char *) assocPtr->firstBgPtr);
334 assocPtr->firstBgPtr = errPtr;
335 }
336
337 if (interp != NULL) {
338 Tcl_Release((ClientData) interp);
339 }
340 }
341 assocPtr->lastBgPtr = NULL;
342
343 Tcl_Release((ClientData) assocPtr);
344 }
345
346 /*
347 *----------------------------------------------------------------------
348 *
349 * BgErrorDeleteProc --
350 *
351 * This procedure is associated with the "tclBgError" assoc data
352 * for an interpreter; it is invoked when the interpreter is
353 * deleted in order to free the information assoicated with any
354 * pending error reports.
355 *
356 * Results:
357 * None.
358 *
359 * Side effects:
360 * Background error information is freed: if there were any
361 * pending error reports, they are cancelled.
362 *
363 *----------------------------------------------------------------------
364 */
365
366 static void
367 BgErrorDeleteProc(clientData, interp)
368 ClientData clientData; /* Pointer to ErrAssocData structure. */
369 Tcl_Interp *interp; /* Interpreter being deleted. */
370 {
371 ErrAssocData *assocPtr = (ErrAssocData *) clientData;
372 BgError *errPtr;
373
374 while (assocPtr->firstBgPtr != NULL) {
375 errPtr = assocPtr->firstBgPtr;
376 assocPtr->firstBgPtr = errPtr->nextPtr;
377 ckfree(errPtr->errorMsg);
378 ckfree(errPtr->errorInfo);
379 ckfree(errPtr->errorCode);
380 ckfree((char *) errPtr);
381 }
382 Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
383 Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
384 }
385
386 /*
387 *----------------------------------------------------------------------
388 *
389 * Tcl_CreateExitHandler --
390 *
391 * Arrange for a given procedure to be invoked just before the
392 * application exits.
393 *
394 * Results:
395 * None.
396 *
397 * Side effects:
398 * Proc will be invoked with clientData as argument when the
399 * application exits.
400 *
401 *----------------------------------------------------------------------
402 */
403
404 void
405 Tcl_CreateExitHandler(proc, clientData)
406 Tcl_ExitProc *proc; /* Procedure to invoke. */
407 ClientData clientData; /* Arbitrary value to pass to proc. */
408 {
409 ExitHandler *exitPtr;
410
411 exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
412 exitPtr->proc = proc;
413 exitPtr->clientData = clientData;
414 Tcl_MutexLock(&exitMutex);
415 exitPtr->nextPtr = firstExitPtr;
416 firstExitPtr = exitPtr;
417 Tcl_MutexUnlock(&exitMutex);
418 }
419
420 /*
421 *----------------------------------------------------------------------
422 *
423 * Tcl_DeleteExitHandler --
424 *
425 * This procedure cancels an existing exit handler matching proc
426 * and clientData, if such a handler exits.
427 *
428 * Results:
429 * None.
430 *
431 * Side effects:
432 * If there is an exit handler corresponding to proc and clientData
433 * then it is cancelled; if no such handler exists then nothing
434 * happens.
435 *
436 *----------------------------------------------------------------------
437 */
438
439 void
440 Tcl_DeleteExitHandler(proc, clientData)
441 Tcl_ExitProc *proc; /* Procedure that was previously registered. */
442 ClientData clientData; /* Arbitrary value to pass to proc. */
443 {
444 ExitHandler *exitPtr, *prevPtr;
445
446 Tcl_MutexLock(&exitMutex);
447 for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
448 prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
449 if ((exitPtr->proc == proc)
450 && (exitPtr->clientData == clientData)) {
451 if (prevPtr == NULL) {
452 firstExitPtr = exitPtr->nextPtr;
453 } else {
454 prevPtr->nextPtr = exitPtr->nextPtr;
455 }
456 ckfree((char *) exitPtr);
457 break;
458 }
459 }
460 Tcl_MutexUnlock(&exitMutex);
461 return;
462 }
463
464 /*
465 *----------------------------------------------------------------------
466 *
467 * Tcl_CreateThreadExitHandler --
468 *
469 * Arrange for a given procedure to be invoked just before the
470 * current thread exits.
471 *
472 * Results:
473 * None.
474 *
475 * Side effects:
476 * Proc will be invoked with clientData as argument when the
477 * application exits.
478 *
479 *----------------------------------------------------------------------
480 */
481
482 void
483 Tcl_CreateThreadExitHandler(proc, clientData)
484 Tcl_ExitProc *proc; /* Procedure to invoke. */
485 ClientData clientData; /* Arbitrary value to pass to proc. */
486 {
487 ExitHandler *exitPtr;
488 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
489
490 exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
491 exitPtr->proc = proc;
492 exitPtr->clientData = clientData;
493 exitPtr->nextPtr = tsdPtr->firstExitPtr;
494 tsdPtr->firstExitPtr = exitPtr;
495 }
496
497 /*
498 *----------------------------------------------------------------------
499 *
500 * Tcl_DeleteThreadExitHandler --
501 *
502 * This procedure cancels an existing exit handler matching proc
503 * and clientData, if such a handler exits.
504 *
505 * Results:
506 * None.
507 *
508 * Side effects:
509 * If there is an exit handler corresponding to proc and clientData
510 * then it is cancelled; if no such handler exists then nothing
511 * happens.
512 *
513 *----------------------------------------------------------------------
514 */
515
516 void
517 Tcl_DeleteThreadExitHandler(proc, clientData)
518 Tcl_ExitProc *proc; /* Procedure that was previously registered. */
519 ClientData clientData; /* Arbitrary value to pass to proc. */
520 {
521 ExitHandler *exitPtr, *prevPtr;
522 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
523
524 for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
525 prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
526 if ((exitPtr->proc == proc)
527 && (exitPtr->clientData == clientData)) {
528 if (prevPtr == NULL) {
529 tsdPtr->firstExitPtr = exitPtr->nextPtr;
530 } else {
531 prevPtr->nextPtr = exitPtr->nextPtr;
532 }
533 ckfree((char *) exitPtr);
534 return;
535 }
536 }
537 }
538
539 /*
540 *----------------------------------------------------------------------
541 *
542 * Tcl_Exit --
543 *
544 * This procedure is called to terminate the application.
545 *
546 * Results:
547 * None.
548 *
549 * Side effects:
550 * All existing exit handlers are invoked, then the application
551 * ends.
552 *
553 *----------------------------------------------------------------------
554 */
555
556 void
557 Tcl_Exit(status)
558 int status; /* Exit status for application; typically
559 * 0 for normal return, 1 for error return. */
560 {
561 Tcl_Finalize();
562 TclpExit(status);
563 }
564
565 /*
566 *-------------------------------------------------------------------------
567 *
568 * TclSetLibraryPath --
569 *
570 * Set the path that will be used for searching for init.tcl and
571 * encodings when an interp is being created.
572 *
573 * Results:
574 * None.
575 *
576 * Side effects:
577 * Changing the library path will affect what directories are
578 * examined when looking for encodings for all interps from that
579 * point forward.
580 *
581 * The refcount of the new library path is incremented and the
582 * refcount of the old path is decremented.
583 *
584 *-------------------------------------------------------------------------
585 */
586
587 void
588 TclSetLibraryPath(pathPtr)
589 Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
590 * the new library path. */
591 {
592 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
593
594 if (pathPtr != NULL) {
595 Tcl_IncrRefCount(pathPtr);
596 }
597 if (tsdPtr->tclLibraryPath != NULL) {
598 Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
599 }
600 tsdPtr->tclLibraryPath = pathPtr;
601 }
602
603 /*
604 *-------------------------------------------------------------------------
605 *
606 * TclGetLibraryPath --
607 *
608 * Return a Tcl list object whose elements are the library path.
609 * The caller should not modify the contents of the returned object.
610 *
611 * Results:
612 * As above.
613 *
614 * Side effects:
615 * None.
616 *
617 *-------------------------------------------------------------------------
618 */
619
620 Tcl_Obj *
621 TclGetLibraryPath()
622 {
623 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
624 return tsdPtr->tclLibraryPath;
625 }
626
627 /*
628 *-------------------------------------------------------------------------
629 *
630 * TclInitSubsystems --
631 *
632 * Initialize various subsytems in Tcl. This should be called the
633 * first time an interp is created, or before any of the subsystems
634 * are used. This function ensures an order for the initialization
635 * of subsystems:
636 *
637 * 1. that cannot be initialized in lazy order because they are
638 * mutually dependent.
639 *
640 * 2. so that they can be finalized in a known order w/o causing
641 * the subsequent re-initialization of a subsystem in the act of
642 * shutting down another.
643 *
644 * Results:
645 * None.
646 *
647 * Side effects:
648 * Varied, see the respective initialization routines.
649 *
650 *-------------------------------------------------------------------------
651 */
652
653 void
654 TclInitSubsystems(argv0)
655 CONST char *argv0; /* Name of executable from argv[0] to main()
656 * in native multi-byte encoding. */
657 {
658 ThreadSpecificData *tsdPtr;
659
660 if (inFinalize != 0) {
661 panic("TclInitSubsystems called while finalizing");
662 }
663
664 /*
665 * Grab the thread local storage pointer before doing anything because
666 * the initialization routines will be registering exit handlers.
667 * We use this pointer to detect if this is the first time this
668 * thread has created an interpreter.
669 */
670
671 tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
672
673 if (subsystemsInitialized == 0) {
674 /*
675 * Double check inside the mutex. There are definitly calls
676 * back into this routine from some of the procedures below.
677 */
678
679 TclpInitLock();
680 if (subsystemsInitialized == 0) {
681 /*
682 * Have to set this bit here to avoid deadlock with the
683 * routines below us that call into TclInitSubsystems.
684 */
685
686 subsystemsInitialized = 1;
687
688 tclExecutableName = NULL;
689
690 /*
691 * Initialize locks used by the memory allocators before anything
692 * interesting happens so we can use the allocators in the
693 * implementation of self-initializing locks.
694 */
695 #if USE_TCLALLOC
696 TclInitAlloc(); /* process wide mutex init */
697 #endif
698 #ifdef TCL_MEM_DEBUG
699 TclInitDbCkalloc(); /* process wide mutex init */
700 #endif
701
702 TclpInitPlatform(); /* creates signal handler(s) */
703 TclInitObjSubsystem(); /* register obj types, create mutexes */
704 TclInitIOSubsystem(); /* inits a tsd key (noop) */
705 TclInitEncodingSubsystem(); /* process wide encoding init */
706 TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
707 }
708 TclpInitUnlock();
709 }
710
711 if (tsdPtr == NULL) {
712 /*
713 * First time this thread has created an interpreter.
714 * We fetch the key again just in case no exit handlers were
715 * registered by this point.
716 */
717
718 (void) TCL_TSD_INIT(&dataKey);
719 TclInitNotifier();
720 }
721 }
722
723 /*
724 *----------------------------------------------------------------------
725 *
726 * Tcl_Finalize --
727 *
728 * Shut down Tcl. First calls registered exit handlers, then
729 * carefully shuts down various subsystems.
730 * Called by Tcl_Exit or when the Tcl shared library is being
731 * unloaded.
732 *
733 * Results:
734 * None.
735 *
736 * Side effects:
737 * Varied, see the respective finalization routines.
738 *
739 *----------------------------------------------------------------------
740 */
741
742 void
743 Tcl_Finalize()
744 {
745 ExitHandler *exitPtr;
746 ThreadSpecificData *tsdPtr;
747
748 TclpInitLock();
749 tsdPtr = TCL_TSD_INIT(&dataKey);
750 if (subsystemsInitialized != 0) {
751 subsystemsInitialized = 0;
752
753 /*
754 * Invoke exit handlers first.
755 */
756
757 Tcl_MutexLock(&exitMutex);
758 inFinalize = 1;
759 for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
760 /*
761 * Be careful to remove the handler from the list before
762 * invoking its callback. This protects us against
763 * double-freeing if the callback should call
764 * Tcl_DeleteExitHandler on itself.
765 */
766
767 firstExitPtr = exitPtr->nextPtr;
768 Tcl_MutexUnlock(&exitMutex);
769 (*exitPtr->proc)(exitPtr->clientData);
770 ckfree((char *) exitPtr);
771 Tcl_MutexLock(&exitMutex);
772 }
773 firstExitPtr = NULL;
774 Tcl_MutexUnlock(&exitMutex);
775
776 /*
777 * Clean up the library path now, before we invalidate thread-local
778 * storage.
779 */
780 if (tsdPtr->tclLibraryPath != NULL) {
781 Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
782 tsdPtr->tclLibraryPath = NULL;
783 }
784
785 /*
786 * Clean up after the current thread now, after exit handlers.
787 * In particular, the testexithandler command sets up something
788 * that writes to standard output, which gets closed.
789 * Note that there is no thread-local storage after this call.
790 */
791
792 Tcl_FinalizeThread();
793
794 /*
795 * Now finalize the Tcl execution environment. Note that this
796 * must be done after the exit handlers, because there are
797 * order dependencies.
798 */
799
800 TclFinalizeCompExecEnv();
801 TclFinalizeEnvironment();
802
803 TclFinalizeEncodingSubsystem();
804
805 if (tclExecutableName != NULL) {
806 ckfree(tclExecutableName);
807 tclExecutableName = NULL;
808 }
809 if (tclNativeExecutableName != NULL) {
810 ckfree(tclNativeExecutableName);
811 tclNativeExecutableName = NULL;
812 }
813 if (tclDefaultEncodingDir != NULL) {
814 ckfree(tclDefaultEncodingDir);
815 tclDefaultEncodingDir = NULL;
816 }
817
818 Tcl_SetPanicProc(NULL);
819
820 /*
821 * Free synchronization objects. There really should only be one
822 * thread alive at this moment.
823 */
824
825 TclFinalizeSynchronization();
826
827 /*
828 * We defer unloading of packages until very late
829 * to avoid memory access issues. Both exit callbacks and
830 * synchronization variables may be stored in packages.
831 */
832
833 TclFinalizeLoad();
834
835 /*
836 * There shouldn't be any malloc'ed memory after this.
837 */
838
839 TclFinalizeMemorySubsystem();
840 inFinalize = 0;
841 }
842 TclpInitUnlock();
843 }
844
845 /*
846 *----------------------------------------------------------------------
847 *
848 * Tcl_FinalizeThread --
849 *
850 * Runs the exit handlers to allow Tcl to clean up its state
851 * about a particular thread.
852 *
853 * Results:
854 * None.
855 *
856 * Side effects:
857 * Varied, see the respective finalization routines.
858 *
859 *----------------------------------------------------------------------
860 */
861
862 void
863 Tcl_FinalizeThread()
864 {
865 ExitHandler *exitPtr;
866 ThreadSpecificData *tsdPtr =
867 (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
868
869 if (tsdPtr != NULL) {
870 /*
871 * Invoke thread exit handlers first.
872 */
873
874 tsdPtr->inExit = 1;
875 for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
876 exitPtr = tsdPtr->firstExitPtr) {
877 /*
878 * Be careful to remove the handler from the list before invoking
879 * its callback. This protects us against double-freeing if the
880 * callback should call Tcl_DeleteThreadExitHandler on itself.
881 */
882
883 tsdPtr->firstExitPtr = exitPtr->nextPtr;
884 (*exitPtr->proc)(exitPtr->clientData);
885 ckfree((char *) exitPtr);
886 }
887 TclFinalizeIOSubsystem();
888 TclFinalizeNotifier();
889
890 /*
891 * Blow away all thread local storage blocks.
892 */
893
894 TclFinalizeThreadData();
895 }
896 }
897
898 /*
899 *----------------------------------------------------------------------
900 *
901 * TclInExit --
902 *
903 * Determines if we are in the middle of exit-time cleanup.
904 *
905 * Results:
906 * If we are in the middle of exiting, 1, otherwise 0.
907 *
908 * Side effects:
909 * None.
910 *
911 *----------------------------------------------------------------------
912 */
913
914 int
915 TclInExit()
916 {
917 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
918 return tsdPtr->inExit;
919 }
920
921 /*
922 *----------------------------------------------------------------------
923 *
924 * Tcl_VwaitObjCmd --
925 *
926 * This procedure is invoked to process the "vwait" Tcl command.
927 * See the user documentation for details on what it does.
928 *
929 * Results:
930 * A standard Tcl result.
931 *
932 * Side effects:
933 * See the user documentation.
934 *
935 *----------------------------------------------------------------------
936 */
937
938 /* ARGSUSED */
939 int
940 Tcl_VwaitObjCmd(clientData, interp, objc, objv)
941 ClientData clientData; /* Not used. */
942 Tcl_Interp *interp; /* Current interpreter. */
943 int objc; /* Number of arguments. */
944 Tcl_Obj *CONST objv[]; /* Argument objects. */
945 {
946 int done, foundEvent;
947 char *nameString;
948
949 if (objc != 2) {
950 Tcl_WrongNumArgs(interp, 1, objv, "name");
951 return TCL_ERROR;
952 }
953 nameString = Tcl_GetString(objv[1]);
954 if (Tcl_TraceVar(interp, nameString,
955 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
956 VwaitVarProc, (ClientData) &done) != TCL_OK) {
957 return TCL_ERROR;
958 };
959 done = 0;
960 foundEvent = 1;
961 while (!done && foundEvent) {
962 foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
963 }
964 Tcl_UntraceVar(interp, nameString,
965 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
966 VwaitVarProc, (ClientData) &done);
967
968 /*
969 * Clear out the interpreter's result, since it may have been set
970 * by event handlers.
971 */
972
973 Tcl_ResetResult(interp);
974 if (!foundEvent) {
975 Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
976 "\": would wait forever", (char *) NULL);
977 return TCL_ERROR;
978 }
979 return TCL_OK;
980 }
981
982 /* ARGSUSED */
983 static char *
984 VwaitVarProc(clientData, interp, name1, name2, flags)
985 ClientData clientData; /* Pointer to integer to set to 1. */
986 Tcl_Interp *interp; /* Interpreter containing variable. */
987 char *name1; /* Name of variable. */
988 char *name2; /* Second part of variable name. */
989 int flags; /* Information about what happened. */
990 {
991 int *donePtr = (int *) clientData;
992
993 *donePtr = 1;
994 return (char *) NULL;
995 }
996
997 /*
998 *----------------------------------------------------------------------
999 *
1000 * Tcl_UpdateObjCmd --
1001 *
1002 * This procedure is invoked to process the "update" Tcl command.
1003 * See the user documentation for details on what it does.
1004 *
1005 * Results:
1006 * A standard Tcl result.
1007 *
1008 * Side effects:
1009 * See the user documentation.
1010 *
1011 *----------------------------------------------------------------------
1012 */
1013
1014 /* ARGSUSED */
1015 int
1016 Tcl_UpdateObjCmd(clientData, interp, objc, objv)
1017 ClientData clientData; /* Not used. */
1018 Tcl_Interp *interp; /* Current interpreter. */
1019 int objc; /* Number of arguments. */
1020 Tcl_Obj *CONST objv[]; /* Argument objects. */
1021 {
1022 int optionIndex;
1023 int flags = 0; /* Initialized to avoid compiler warning. */
1024 static char *updateOptions[] = {"idletasks", (char *) NULL};
1025 enum updateOptions {REGEXP_IDLETASKS};
1026
1027 if (objc == 1) {
1028 flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
1029 } else if (objc == 2) {
1030 if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
1031 "option", 0, &optionIndex) != TCL_OK) {
1032 return TCL_ERROR;
1033 }
1034 switch ((enum updateOptions) optionIndex) {
1035 case REGEXP_IDLETASKS: {
1036 flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
1037 break;
1038 }
1039 default: {
1040 panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
1041 }
1042 }
1043 } else {
1044 Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
1045 return TCL_ERROR;
1046 }
1047
1048 while (Tcl_DoOneEvent(flags) != 0) {
1049 /* Empty loop body */
1050 }
1051
1052 /*
1053 * Must clear the interpreter's result because event handlers could
1054 * have executed commands.
1055 */
1056
1057 Tcl_ResetResult(interp);
1058 return TCL_OK;
1059 }
1060
1061
1062 /* $History: tclevent.c $
1063 *
1064 * ***************** Version 1 *****************
1065 * User: Dtashley Date: 1/02/01 Time: 1:26a
1066 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
1067 * Initial check-in.
1068 */
1069
1070 /* End of TCLEVENT.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25