diff -r 000000000000 -r 08ec8eefde2f persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclMain.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclMain.c Fri Jan 22 11:06:30 2010 +0200 @@ -0,0 +1,753 @@ +/* + * tclMain.c -- + * + * Main program for Tcl shells and other Tcl-based applications. + * + * Copyright (c) 1988-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2000 Ajuba Solutions. + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclMain.c,v 1.20.2.3 2006/05/05 18:08:58 dgp Exp $ + */ + +#include "tcl.h" +#include "tclInt.h" +#if defined(__SYMBIAN32__) +#include "tclPort.h" +#include "tclSymbianGlobals.h" +#include "tclIntPlatDecls.h" +#endif + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT + +/* + * Declarations for various library procedures and variables (don't want + * to include tclPort.h here, because people might copy this file out of + * the Tcl source directory to make their own modified versions). + */ + +#if !defined(MAC_TCL) +extern int isatty _ANSI_ARGS_((int fd)); +#else +#include +#endif + +static Tcl_Obj *tclStartupScriptPath = NULL; + +static Tcl_MainLoopProc *mainLoopProc = NULL; + +/* + * Structure definition for information used to keep the state of + * an interactive command processor that reads lines from standard + * input and writes prompts and results to standard output. + */ + +typedef enum { + PROMPT_NONE, /* Print no prompt */ + PROMPT_START, /* Print prompt for command start */ + PROMPT_CONTINUE /* Print prompt for command continuation */ +} PromptType; + +typedef struct InteractiveState { + Tcl_Channel input; /* The standard input channel from which + * lines are read. */ + int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ + Tcl_Obj *commandPtr; /* Used to assemble lines of input into + * Tcl commands. */ + PromptType prompt; /* Next prompt to print */ + Tcl_Interp *interp; /* Interpreter that evaluates interactive + * commands. */ +} InteractiveState; + +/* + * Forward declarations for procedures defined later in this file. + */ + +static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, + PromptType *promptPtr)); +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptPath -- + * + * Primes the startup script VFS path, used to override the + * command line processing. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the VFS path of the Tcl script to + * run at startup. + * + *---------------------------------------------------------------------- + */ +void TclSetStartupScriptPath(pathPtr) + Tcl_Obj *pathPtr; +{ + if (tclStartupScriptPath != NULL) { + Tcl_DecrRefCount(tclStartupScriptPath); + } + tclStartupScriptPath = pathPtr; + if (tclStartupScriptPath != NULL) { + Tcl_IncrRefCount(tclStartupScriptPath); + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptPath -- + * + * Gets the startup script VFS path, used to override the + * command line processing. + * + * Results: + * The startup script VFS path, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj *TclGetStartupScriptPath() +{ + return tclStartupScriptPath; +} + + +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptFileName -- + * + * Primes the startup script file name, used to override the + * command line processing. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the file name of the Tcl script to + * run at startup. + * + *---------------------------------------------------------------------- + */ +void TclSetStartupScriptFileName(fileName) + CONST char *fileName; +{ + Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); + TclSetStartupScriptPath(pathPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptFileName -- + * + * Gets the startup script file name, used to override the + * command line processing. + * + * Results: + * The startup script file name, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +CONST char *TclGetStartupScriptFileName() +{ + Tcl_Obj *pathPtr = TclGetStartupScriptPath(); + + if (pathPtr == NULL) { + return NULL; + } + return Tcl_GetString(pathPtr); +} + + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Main -- + * + * Main program for tclsh and most other Tcl-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done). + * + * Side effects: + * This procedure initializes the Tcl world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; + /* Application-specific initialization + * procedure to call after most + * initialization but before starting to + * execute commands. */ +{ + Tcl_Obj *resultPtr, *argvPtr, *commandPtr = NULL; + PromptType prompt = PROMPT_START; + int code, length, tty, exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_Interp *interp; + Tcl_DString appName; + Tcl_Obj *objPtr; + +#if defined(__SYMBIAN32__) + int isChildProcess = 0; + int oldArgc = 0; +#endif + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); + +#if defined(__SYMBIAN32__) + if (ChildProcessInit(&argc, &argv)) + { + oldArgc = argc; + argc = argc-4; + isChildProcess = 1; + } + #endif + + Tcl_InitMemory(interp); + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". If the first argument doesn't start with a "-" then + * strip it off and use it as the name of a script file to process. + */ + + if (TclGetStartupScriptPath() == NULL) { + if ((argc > 1) && (argv[1][0] != '-')) { + TclSetStartupScriptFileName(argv[1]); + argc--; + argv++; + } + } + + if (TclGetStartupScriptPath() == NULL) { + Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); + } else { + TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL, + TclGetStartupScriptFileName(), -1, &appName)); + } + Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); + Tcl_DStringFree(&appName); + argc--; + argv++; + + objPtr = Tcl_NewIntObj(argc); + Tcl_IncrRefCount(objPtr); + Tcl_SetVar2Ex(interp, "argc", NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); + + argvPtr = Tcl_NewListObj(0, NULL); + while (argc--) { + Tcl_DString ds; + Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); + Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } + Tcl_IncrRefCount(argvPtr); + Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(argvPtr); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0", + TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + Tcl_Preserve((ClientData) interp); + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_WriteChars(errChannel, + "application-specific initialization failed: ", -1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + } + if (Tcl_InterpDeleted(interp)) { + goto done; + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (TclGetStartupScriptPath() != NULL) { + code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath()); + if (code != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo", + NULL, TCL_GLOBAL_ONLY)); + Tcl_WriteChars(errChannel, "\n", 1); + } + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if the application specified one and if the file exists. + */ + + Tcl_SourceRCFile(interp); + + /* + * Process commands from stdin until there's an end-of-file. Note + * that we need to fetch the standard channels again after every + * eval, since they may have been changed. + */ + + commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(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 != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { + if (mainLoopProc == NULL) { + if (tty) { + Prompt(interp, &prompt); + if (Tcl_InterpDeleted(interp)) { + break; + } + inChannel = Tcl_GetStdChannel(TCL_STDIN); + if (inChannel == (Tcl_Channel) NULL) { + break; + } + } + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + length = Tcl_GetsObj(inChannel, commandPtr); + if (length < 0) { + if (Tcl_InputBlocked(inChannel)) { + + /* + * This can only happen if stdin has been set to + * non-blocking. In that case cycle back and try + * again. This sets up a tight polling loop (since + * we have no event loop running). If this causes + * bad CPU hogging, we might try toggling the blocking + * on stdin instead. + */ + + continue; + } + + /* + * Either EOF, or an error on stdin; we're done + */ + + break; + } + + /* + * Add the newline removed by Tcl_GetsObj back to the string. + */ + + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + prompt = PROMPT_CONTINUE; + continue; + } + + prompt = PROMPT_START; + 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); + if (code != TCL_OK) { + if (errChannel) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + } else if (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); + } + Tcl_DecrRefCount(resultPtr); + } + } else { /* (mainLoopProc != NULL) */ + /* + * If a main loop has been defined while running interactively, + * we want to start a fileevent based prompt by establishing a + * channel handler for stdin. + */ + + InteractiveState *isPtr = NULL; + + if (inChannel) { + if (tty) { + Prompt(interp, &prompt); + } + isPtr = (InteractiveState *) + ckalloc((int) 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, + (ClientData) isPtr); + } + + (*mainLoopProc)(); + mainLoopProc = 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 != (Tcl_Channel) NULL) { + Tcl_DeleteChannelHandler(isPtr->input, StdinProc, + (ClientData) isPtr); + } + ckfree((char *)isPtr); + } + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + } +#ifdef TCL_MEM_DEBUG + + /* + * This code here only for the (unsupported and deprecated) + * [checkmem] command. + */ + + if (tclMemDumpFileName != NULL) { + mainLoopProc = NULL; + Tcl_DeleteInterp(interp); + } +#endif + } + + done: + if ((exitCode == 0) && (mainLoopProc != NULL)) { + + /* + * 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 this point. + */ + + (*mainLoopProc)(); + mainLoopProc = NULL; + } + if (commandPtr != NULL) { + Tcl_DecrRefCount(commandPtr); + } + +#if defined(__SYMBIAN32__) + ChildProcessCleanup(isChildProcess, oldArgc, argv); +#else + close (TCL_STDIN); + close (TCL_STDOUT); + close (TCL_STDERR); //every process has a error file +#endif + + /* + * Rather than calling exit, invoke the "exit" command so that + * users can replace "exit" with some other command to do additional + * cleanup on exit. The Tcl_Eval call should never return. + */ + + if (!Tcl_InterpDeleted(interp)) { + char buffer[TCL_INTEGER_SPACE + 5]; + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); + + /* + * If Tcl_Eval returns, trying to eval [exit], something + * unusual is happening. Maybe interp has been deleted; + * maybe [exit] was redefined. We still want to cleanup + * and exit. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } + } + TclSetStartupScriptPath(NULL); + + /* + * If we get here, the master interp has been deleted. Allow + * its destruction with the last matching Tcl_Release. + */ + + Tcl_Release((ClientData) interp); + Tcl_Exit(exitCode); +} + +/* + *--------------------------------------------------------------- + * + * Tcl_SetMainLoop -- + * + * Sets an alternative main loop procedure. + * + * Results: + * Returns the previously defined main loop procedure. + * + * Side effects: + * This procedure will be called before Tcl exits, allowing for + * the creation of an event loop. + * + *--------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_SetMainLoop(proc) + Tcl_MainLoopProc *proc; +{ + mainLoopProc = proc; +} + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +StdinProc(clientData, mask) + ClientData clientData; /* The state of interactive cmd line */ + int mask; /* Not used. */ +{ + InteractiveState *isPtr = (InteractiveState *) 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); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + length = Tcl_GetsObj(chan, commandPtr); + if (length < 0) { + if (Tcl_InputBlocked(chan)) { + return; + } + if (isPtr->tty) { + /* + * Would be better to find a way to exit the mainLoop? + * Or perhaps evaluate [exit]? Leaving as is for now due + * to compatibility concerns. + */ + Tcl_Exit(0); + } + Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); + return; + } + + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + isPtr->prompt = PROMPT_CONTINUE; + goto prompt; + } + isPtr->prompt = PROMPT_START; + + /* + * Disable the stdin channel handler while evaluating the command; + * otherwise if the command re-enters the event loop we might + * process commands from stdin before the current command is + * finished. Among other things, this will trash the text of the + * command being evaluated. + */ + + Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); + code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); + isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); + Tcl_DecrRefCount(commandPtr); + isPtr->commandPtr = commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(commandPtr); + if (chan != (Tcl_Channel) NULL) { + Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, + (ClientData) isPtr); + } + if (code != TCL_OK) { + Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + } else if (isPtr->tty) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); + Tcl_IncrRefCount(resultPtr); + Tcl_GetStringFromObj(resultPtr, &length); + if ((length >0) && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteObj(outChannel, resultPtr); + Tcl_WriteChars(outChannel, "\n", 1); + } + Tcl_DecrRefCount(resultPtr); + } + + /* + * If a tty stdin is still around, output a prompt. + */ + + prompt: + if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { + Prompt(interp, &(isPtr->prompt)); + isPtr->input = Tcl_GetStdChannel(TCL_STDIN); + } +} + +/* + *---------------------------------------------------------------------- + * + * Prompt -- + * + * Issue a prompt on standard output, or invoke a script + * to issue the prompt. + * + * Results: + * None. + * + * Side effects: + * A prompt gets output, and a Tcl script may be evaluated + * in interp. + * + *---------------------------------------------------------------------- + */ + +static void +Prompt(interp, promptPtr) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + PromptType *promptPtr; /* Points to type of prompt to print. + * Filled with PROMPT_NONE after a + * prompt is printed. */ +{ + Tcl_Obj *promptCmdPtr; + int code; + Tcl_Channel outChannel, errChannel; + + if (*promptPtr == PROMPT_NONE) { + return; + } + + promptCmdPtr = Tcl_GetVar2Ex(interp, + ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + NULL, TCL_GLOBAL_ONLY); + if (Tcl_InterpDeleted(interp)) { + return; + } + if (promptCmdPtr == NULL) { + defaultPrompt: + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if ((*promptPtr == PROMPT_START) + && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteChars(outChannel, "% ", 2); + } + } else { + code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + goto defaultPrompt; + } + } + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Flush(outChannel); + } + *promptPtr = PROMPT_NONE; +}