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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25