Attachment "setappexit3.diff" to
ticket [649313ffff]
added by
mistachkin
2003-03-22 04:34:01.
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.94
diff -b -u -r1.94 tcl.decls
--- generic/tcl.decls 31 Aug 2002 06:09:45 -0000 1.94
+++ generic/tcl.decls 21 Mar 2003 21:06:42 -0000
@@ -1754,6 +1754,11 @@
Tcl_ChannelType *chanTypePtr)
}
+# New export for custom app exit handling
+declare 494 generic {
+ Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.93
diff -b -u -r1.93 tclDecls.h
--- generic/tclDecls.h 5 Aug 2002 15:01:04 -0000 1.93
+++ generic/tclDecls.h 21 Mar 2003 21:06:48 -0000
@@ -1564,6 +1564,9 @@
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
+/* 494 */
+EXTERN Tcl_ExitProc * Tcl_SetExitProc _ANSI_ARGS_((
+ Tcl_ExitProc *proc));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -2117,6 +2120,7 @@
Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */
+ Tcl_ExitProc * (*Tcl_SetExitProc) _ANSI_ARGS_((Tcl_ExitProc *proc)); /* 494 */
} TclStubs;
#ifdef __cplusplus
@@ -4132,6 +4136,10 @@
#ifndef Tcl_ChannelWideSeekProc
#define Tcl_ChannelWideSeekProc \
(tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */
+#endif
+#ifndef Tcl_SetExitProc
+#define Tcl_SetExitProc \
+ (tclStubsPtr->Tcl_SetExitProc) /* 494 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclEvent.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v
retrieving revision 1.28
diff -b -u -r1.28 tclEvent.c
--- generic/tclEvent.c 22 Feb 2003 09:23:16 -0000 1.28
+++ generic/tclEvent.c 21 Mar 2003 21:06:49 -0000
@@ -88,6 +88,14 @@
static int inFinalize = 0;
static int subsystemsInitialized = 0;
+/*
+ * This variable contains the application wide exit handler. It will be
+ * called by Tcl_Exit instead of the C-runtime exit if this variable is set
+ * to a non-NULL value.
+ */
+
+static Tcl_ExitProc *appExitPtr = NULL;
+
typedef struct ThreadSpecificData {
ExitHandler *firstExitPtr; /* First in list of all exit handlers for
* this thread. */
@@ -542,6 +550,38 @@
/*
*----------------------------------------------------------------------
*
+ * Tcl_SetExitProc --
+ *
+ * This procedure sets the application wide exit handler that will be
+ * called by Tcl_Exit in place of the C-runtime exit. If the
+ * application wide exit handler is NULL, the C-runtime exit will be
+ * used instead.
+ *
+ * Results:
+ * The previously set application wide exit handler.
+ *
+ * Side effects:
+ * Sets the application wide exit handler to the specified value.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_ExitProc *
+Tcl_SetExitProc(proc)
+ Tcl_ExitProc *proc; /* new exit handler for app or NULL */
+{
+ Tcl_ExitProc *prevExitProc; /* return prev exit handler to caller */
+
+ Tcl_MutexLock(&exitMutex);
+ prevExitProc = appExitPtr; /* get old app exit ptr */
+ appExitPtr = proc; /* set new app exit ptr */
+ Tcl_MutexUnlock(&exitMutex);
+
+ return prevExitProc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Exit --
*
* This procedure is called to terminate the application.
@@ -561,8 +601,25 @@
int status; /* Exit status for application; typically
* 0 for normal return, 1 for error return. */
{
+ Tcl_ExitProc *currentAppExitPtr;
+
+ Tcl_MutexLock(&exitMutex);
+ currentAppExitPtr = appExitPtr;
+ Tcl_MutexUnlock(&exitMutex);
+
+ if (currentAppExitPtr) {
+ /***********************************************************/
+ /* WARNING: This code SHOULD NOT return, as there is code */
+ /* that depends on Tcl_Exit never returning. */
+ /***********************************************************/
+ currentAppExitPtr((ClientData) status);
+ } else {
+ /* use default handling */
Tcl_Finalize();
TclpExit(status);
+ }
+
+ Tcl_Panic ("exitProc returned!");
}
/*
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.80
diff -b -u -r1.80 tclStubInit.c
--- generic/tclStubInit.c 21 Mar 2003 03:23:24 -0000 1.80
+++ generic/tclStubInit.c 21 Mar 2003 21:06:50 -0000
@@ -925,6 +925,7 @@
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
+ Tcl_SetExitProc, /* 494 */
};
/* !END!: Do not edit above this line. */
