diff options
Diffstat (limited to 'generic/tclMain.c')
| -rw-r--r-- | generic/tclMain.c | 195 |
1 files changed, 132 insertions, 63 deletions
diff --git a/generic/tclMain.c b/generic/tclMain.c index 26383b5..360f5e9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -16,11 +16,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/** - * On Windows, this file needs to be compiled twice, once with - * TCL_ASCII_MAIN defined. This way both Tcl_Main and Tcl_MainExW - * can be implemented, sharing the same source code. +/* + * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN + * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing + * the same source code. */ + #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE @@ -40,33 +41,36 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* - * This file can be compiled on Windows in UNICODE mode, as well as - * on all other platforms using the native encoding. This is done - * by using the normal Windows functions like _tcscmp, but on - * platforms which don't have <tchar.h> we have to translate that - * to strcmp here. + * This file can be compiled on Windows in UNICODE mode, as well as on all + * other platforms using the native encoding. This is done by using the normal + * Windows functions like _tcscmp, but on platforms which don't have <tchar.h> + * we have to translate that to strcmp here. */ -#ifndef __WIN32__ + +#ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp #endif /* - * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj, - * while otherwise NewNativeObj is needed (which provides proper - * conversion from native encoding to UTF-8). + * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise + * NewNativeObj is needed (which provides proper conversion from native + * encoding to UTF-8). */ + #ifdef UNICODE # define NewNativeObj Tcl_NewUnicodeObj #else /* !UNICODE */ - static Tcl_Obj *NewNativeObj(char *string, int length) { - Tcl_Obj *obj; - Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - return obj; +static inline Tcl_Obj * +NewNativeObj( + char *string, + int length) +{ + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, string, length, &ds); + return TclDStringToObj(&ds); } #endif /* !UNICODE */ @@ -125,9 +129,11 @@ typedef struct InteractiveState { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); +static void FreeMainInterp(ClientData clientData); #ifndef TCL_ASCII_MAIN static Tcl_ThreadDataKey dataKey; + /* *---------------------------------------------------------------------- * @@ -307,6 +313,9 @@ Tcl_MainEx( Tcl_Channel chan; InteractiveState is; + TclpSetInitialEncodings(); + TclpFindExecutable((const char *)argv[0]); + Tcl_InitMemory(interp); is.interp = interp; @@ -328,13 +337,14 @@ Tcl_MainEx( */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) - && (TEXT('-') != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2], -1); - Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); + && ('-' != argv[3][0])) { + Tcl_Obj *value = NewNativeObj(argv[2], -1); + Tcl_SetStartupScript(NewNativeObj(argv[3], -1), + Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; - } else if ((argc > 1) && (TEXT('-') != argv[1][0])) { + } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; @@ -387,6 +397,14 @@ Tcl_MainEx( if (Tcl_LimitExceeded(interp)) { goto done; } + if (TclFullFinalizationRequested()) { + /* + * Arrange for final deletion of the main interp + */ + + /* ARGH Munchhausen effect */ + Tcl_CreateExitHandler(FreeMainInterp, interp); + } /* * Invoke the script specified on the command line, if any. Must fetch it @@ -447,6 +465,7 @@ Tcl_MainEx( mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; + if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { @@ -512,7 +531,8 @@ Tcl_MainEx( Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, + TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); @@ -546,7 +566,8 @@ Tcl_MainEx( Prompt(interp, &is); } - Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); + Tcl_CreateChannelHandler(is.input, TCL_READABLE, + StdinProc, &is); } mainLoopProc(); @@ -557,24 +578,23 @@ Tcl_MainEx( } is.input = Tcl_GetStdChannel(TCL_STDIN); } -#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ +#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } -#endif +#endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); - if ((exitCode == 0) && (mainLoopProc != NULL) - && !Tcl_LimitExceeded(interp)) { + if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at @@ -594,51 +614,38 @@ Tcl_MainEx( * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp)) { - if (!Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); - } - - /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual - * is happening. Maybe interp has been deleted; maybe [exit] was - * redefined, maybe we've blown up because of an exceeded limit. We - * still want to cleanup and exit. - */ - - if (!Tcl_InterpDeleted(interp)) { - Tcl_DeleteInterp(interp); - } + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); } - Tcl_SetStartupScript(NULL, NULL); /* - * If we get here, the master interp has been deleted. Allow its - * destruction with the last matching Tcl_Release. + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is + * happening. Maybe interp has been deleted; maybe [exit] was redefined, + * maybe we've blown up because of an exceeded limit. We still want to + * cleanup and exit. */ - Tcl_Release(interp); Tcl_Exit(exitCode); } -#ifndef UNICODE -void +#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE) +#undef Tcl_Main +extern DLLEXPORT void Tcl_Main( int argc, /* Number of arguments. */ - TCHAR **argv, /* Array of argument strings. */ + char **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc) /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ { - Tcl_FindExecutable(argv[0]); - Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); + Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); } -#endif +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -694,6 +701,43 @@ TclGetMainLoop(void) return tsdPtr->mainLoopProc; } + +/* + *---------------------------------------------------------------------- + * + * TclFullFinalizationRequested -- + * + * This function returns true when either -DPURIFY is specified, or the + * environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This + * predicate is called at places affecting the exit sequence, so that the + * default behavior is a fast and deadlock-free exit, and the modified + * behavior is a more thorough finalization for debugging purposes (leak + * hunting etc). + * + * Results: + * A boolean. + * + *---------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclFullFinalizationRequested(void) +{ +#ifdef PURIFY + return 1; +#else + const char *fin; + Tcl_DString ds; + int finalize = 0; + + fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds); + finalize = ((fin != NULL) && strcmp(fin, "0")); + if (fin != NULL) { + Tcl_DStringFree(&ds); + } + return finalize; +#endif /* PURIFY */ +} #endif /* !TCL_ASCII_MAIN */ /* @@ -831,9 +875,8 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - InteractiveState *isPtr) /* InteractiveState. Filled - * with PROMPT_NONE after a prompt is - * printed. */ + InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE + * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; @@ -844,7 +887,7 @@ Prompt( } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -881,6 +924,32 @@ Prompt( } /* + *---------------------------------------------------------------------- + * + * FreeMainInterp -- + * + * Exit handler used to cleanup the main interpreter and ancillary + * startup script storage at exit. + * + *---------------------------------------------------------------------- + */ + +static void +FreeMainInterp( + ClientData clientData) +{ + Tcl_Interp *interp = clientData; + + /*if (TclInExit()) return;*/ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } + Tcl_SetStartupScript(NULL, NULL); + Tcl_Release(interp); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |