From efac6ea792b9082ca65d083e4364b6f7fa7fddda Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2011 16:12:15 +0000 Subject: [Patch #3124683]: platform specific stuff in (tcl|tk)Main.c --- ChangeLog | 5 + generic/tclMain.c | 285 +++++++++++++++++++++++++----------------------------- 2 files changed, 135 insertions(+), 155 deletions(-) diff --git a/ChangeLog b/ChangeLog index 21bc07c..4ad8d68 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-03-17 Jan Nijtmans + + * generic/tkMain.c: [Patch #3124683]: platform specific + stuff in (tcl|tk)Main.c + 2011-03-16 Jan Nijtmans * generic/tclCkalloc.c: [Bug #3197864] pointer truncation on Win64 diff --git a/generic/tclMain.c b/generic/tclMain.c index 1b3b091..26383b5 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -2,6 +2,11 @@ * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. + * This file contains a generic main program for Tcl shells and other + * Tcl-based applications. It can be used as-is for many applications, + * just by supplying a different appInitProc function for each specific + * application. Or, it can be used as a template for creating new main + * programs for Tcl applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -45,23 +50,24 @@ # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp -# define _tcslen strlen -# define _tcsncmp strncmp #endif /* - * Further on, in UNICODE mode, we need to use functions like - * Tcl_GetUnicodeFromObj, while otherwise Tcl_GetStringFromObj - * is needed. Those macro's assure that the right functions - * are used depending on the mode. + * 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). */ -#ifndef UNICODE -# undef Tcl_GetUnicodeFromObj -# define Tcl_GetUnicodeFromObj Tcl_GetStringFromObj -# undef Tcl_NewUnicodeObj -# define Tcl_NewUnicodeObj Tcl_NewStringObj -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +#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; +} #endif /* !UNICODE */ /* @@ -117,7 +123,7 @@ typedef struct InteractiveState { */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); -static void Prompt(Tcl_Interp *interp, PromptType *promptPtr); +static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); #ifndef TCL_ASCII_MAIN @@ -229,7 +235,7 @@ Tcl_SourceRCFile( { Tcl_DString temp; const char *fileName; - Tcl_Channel errChannel; + Tcl_Channel chan; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { @@ -253,10 +259,10 @@ Tcl_SourceRCFile( if (c != NULL) { Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } } @@ -294,16 +300,19 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; + Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; - PromptType prompt = PROMPT_START; - int code, length, tty, exitCode = 0; + int code, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; - Tcl_Channel inChannel, outChannel, errChannel; - Tcl_DString appName; + Tcl_Channel chan; + InteractiveState is; Tcl_InitMemory(interp); + is.interp = interp; + is.prompt = PROMPT_START; + is.commandPtr = Tcl_NewObj(); + /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and @@ -320,13 +329,13 @@ Tcl_MainEx( if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && (TEXT('-') != argv[3][0])) { - Tcl_Obj *value = Tcl_NewUnicodeObj(argv[2], -1); - Tcl_SetStartupScript(Tcl_NewUnicodeObj(argv[3], -1), Tcl_GetString(value)); + 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])) { - Tcl_SetStartupScript(Tcl_NewUnicodeObj(argv[1], -1), NULL); + Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } @@ -334,16 +343,11 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - Tcl_WinTCharToUtf(argv[0], -1, &appName); + appName = NewNativeObj(argv[0], -1); } else { - const TCHAR *pathName = Tcl_GetUnicodeFromObj(path, &length); - - Tcl_WinTCharToUtf(pathName, length * sizeof(TCHAR), &appName); - path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); - Tcl_SetStartupScript(path, encodingName); + appName = path; } - Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); - Tcl_DStringFree(&appName); + Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; @@ -351,12 +355,7 @@ Tcl_MainEx( argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_DString ds; - - Tcl_WinTCharToUtf(*argv++, -1, &ds); - Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( - Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); @@ -364,9 +363,9 @@ Tcl_MainEx( * Set the "tcl_interactive" variable. */ - tty = isatty(0); - Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", - TCL_GLOBAL_ONLY); + is.tty = isatty(0); + Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, + Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. @@ -374,12 +373,12 @@ Tcl_MainEx( Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_WriteChars(errChannel, + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteChars(chan, "application-specific initialization failed: ", -1); - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { @@ -390,16 +389,17 @@ Tcl_MainEx( } /* - * If a script file was specified then just source that file and quit. - * Must fetch it again, as the appInitProc might have reset it. + * Invoke the script specified on the command line, if any. Must fetch it + * again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { + Tcl_ResetResult(interp); code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; @@ -409,9 +409,9 @@ Tcl_MainEx( Tcl_DecrRefCount(keyPtr); if (valuePtr) { - Tcl_WriteObj(errChannel, valuePtr); + Tcl_WriteObj(chan, valuePtr); } - Tcl_WriteChars(errChannel, "\n", 1); + Tcl_WriteChars(chan, "\n", 1); Tcl_DecrRefCount(options); } exitCode = 1; @@ -435,40 +435,39 @@ Tcl_MainEx( * may have been changed. */ - commandPtr = Tcl_NewObj(); - Tcl_IncrRefCount(commandPtr); + Tcl_IncrRefCount(is.commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ - Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) { + Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN); + is.input = Tcl_GetStdChannel(TCL_STDIN); + while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { - if (tty) { - Prompt(interp, &prompt); + int length; + if (is.tty) { + Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } - inChannel = Tcl_GetStdChannel(TCL_STDIN); - if (inChannel == NULL) { + is.input = Tcl_GetStdChannel(TCL_STDIN); + if (is.input == NULL) { break; } } - if (Tcl_IsShared(commandPtr)) { - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_DuplicateObj(commandPtr); - Tcl_IncrRefCount(commandPtr); + if (Tcl_IsShared(is.commandPtr)) { + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_DuplicateObj(is.commandPtr); + Tcl_IncrRefCount(is.commandPtr); } - length = Tcl_GetsObj(inChannel, commandPtr); + length = Tcl_GetsObj(is.input, is.commandPtr); if (length < 0) { - if (Tcl_InputBlocked(inChannel)) { + if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. @@ -493,45 +492,45 @@ Tcl_MainEx( * a difference. [Bug 1775878] */ - if (Tcl_IsShared(commandPtr)) { - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_DuplicateObj(commandPtr); - Tcl_IncrRefCount(commandPtr); + if (Tcl_IsShared(is.commandPtr)) { + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_DuplicateObj(is.commandPtr); + Tcl_IncrRefCount(is.commandPtr); } - Tcl_AppendToObj(commandPtr, "\n", 1); - if (!TclObjCommandComplete(commandPtr)) { - prompt = PROMPT_CONTINUE; + Tcl_AppendToObj(is.commandPtr, "\n", 1); + if (!TclObjCommandComplete(is.commandPtr)) { + is.prompt = PROMPT_CONTINUE; continue; } - prompt = PROMPT_START; + is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(commandPtr, &length); - Tcl_SetObjLength(commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - errChannel = Tcl_GetStdChannel(TCL_STDERR); - Tcl_DecrRefCount(commandPtr); - commandPtr = Tcl_NewObj(); - Tcl_IncrRefCount(commandPtr); + Tcl_GetStringFromObj(is.commandPtr, &length); + Tcl_SetObjLength(is.commandPtr, --length); + code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); + is.input = Tcl_GetStdChannel(TCL_STDIN); + Tcl_DecrRefCount(is.commandPtr); + is.commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } - } else if (tty) { + } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); - if ((length > 0) && outChannel) { - Tcl_WriteObj(outChannel, resultPtr); - Tcl_WriteChars(outChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDOUT); + if ((length > 0) && chan) { + Tcl_WriteObj(chan, resultPtr); + Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } @@ -542,45 +541,21 @@ Tcl_MainEx( * channel handler for stdin. */ - InteractiveState *isPtr = NULL; - - if (inChannel) { - if (tty) { - Prompt(interp, &prompt); + if (is.input) { + if (is.tty) { + Prompt(interp, &is); } - isPtr = ckalloc(sizeof(InteractiveState)); - isPtr->input = inChannel; - isPtr->tty = tty; - isPtr->commandPtr = commandPtr; - isPtr->prompt = prompt; - isPtr->interp = interp; - - Tcl_UnlinkVar(interp, "tcl_interactive"); - Tcl_LinkVar(interp, "tcl_interactive", (char *) &isPtr->tty, - TCL_LINK_BOOLEAN); - - Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, - isPtr); + + Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); } mainLoopProc(); Tcl_SetMainLoop(NULL); - if (inChannel) { - tty = isPtr->tty; - Tcl_UnlinkVar(interp, "tcl_interactive"); - Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, - TCL_LINK_BOOLEAN); - prompt = isPtr->prompt; - commandPtr = isPtr->commandPtr; - if (isPtr->input != NULL) { - Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr); - } - ckfree(isPtr); + if (is.input) { + Tcl_DeleteChannelHandler(is.input, StdinProc, &is); } - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - errChannel = Tcl_GetStdChannel(TCL_STDERR); + is.input = Tcl_GetStdChannel(TCL_STDIN); } #ifdef TCL_MEM_DEBUG @@ -609,8 +584,8 @@ Tcl_MainEx( mainLoopProc(); Tcl_SetMainLoop(NULL); } - if (commandPtr != NULL) { - Tcl_DecrRefCount(commandPtr); + if (is.commandPtr != NULL) { + Tcl_DecrRefCount(is.commandPtr); } /* @@ -746,11 +721,11 @@ StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { + int code, length; InteractiveState *isPtr = clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; - int code, length; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); @@ -806,21 +781,21 @@ StdinProc( Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); } if (code != TCL_OK) { - Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + chan = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + if (chan != NULL) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); + chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); - if ((length >0) && (outChannel != NULL)) { - Tcl_WriteObj(outChannel, resultPtr); - Tcl_WriteChars(outChannel, "\n", 1); + if ((length > 0) && (chan != NULL)) { + Tcl_WriteObj(chan, resultPtr); + Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } @@ -831,7 +806,7 @@ StdinProc( prompt: if (isPtr->tty && (isPtr->input != NULL)) { - Prompt(interp, &isPtr->prompt); + Prompt(interp, isPtr); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } } @@ -856,20 +831,20 @@ StdinProc( static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - PromptType *promptPtr) /* Points to type of prompt to print. Filled + InteractiveState *isPtr) /* InteractiveState. Filled * with PROMPT_NONE after a prompt is * printed. */ { Tcl_Obj *promptCmdPtr; int code; - Tcl_Channel outChannel, errChannel; + Tcl_Channel chan; - if (*promptPtr == PROMPT_NONE) { + if (isPtr->prompt == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, - ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { @@ -877,10 +852,10 @@ Prompt( } if (promptCmdPtr == NULL) { defaultPrompt: - if (*promptPtr == PROMPT_START) { - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - if (outChannel != NULL) { - Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, + if (isPtr->prompt == PROMPT_START) { + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != NULL) { + Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } @@ -889,20 +864,20 @@ Prompt( if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != NULL) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); } goto defaultPrompt; } } - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - if (outChannel != NULL) { - Tcl_Flush(outChannel); + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != NULL) { + Tcl_Flush(chan); } - *promptPtr = PROMPT_NONE; + isPtr->prompt = PROMPT_NONE; } /* -- cgit v0.12