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

Annotation of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 1 month 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 dashley 25 /* $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