/* * 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. * * 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" # 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; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); 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); } /* * 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. * *--------------------------------------------------------------- */ 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; }