static void TclKit_InitStdChannels(void) { Tcl_Channel chan; /* * We need to verify if we have the standard channels and create them if * not. Otherwise internals channels may get used as standard channels * (like for encodings) and panic. */ chan = Tcl_GetStdChannel(TCL_STDIN); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } Tcl_SetStdChannel(chan, TCL_STDIN); } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } Tcl_SetStdChannel(chan, TCL_STDOUT); } chan = Tcl_GetStdChannel(TCL_STDERR); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } Tcl_SetStdChannel(chan, TCL_STDERR); } }
int tclcommand_replacestdchannel(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { Tcl_Channel channel=NULL; if (argc != 3){ Tcl_AppendResult(interp,"Wrong # of args! Usage: ",argv[0]," [stdout|stderr|stdin] <pipename>",(char *)NULL); return TCL_ERROR; } if(access(argv[2],F_OK)<0){ Tcl_AppendResult(interp,"File ",argv[2]," does not exist!",(char *) NULL); return TCL_ERROR; } if(strcmp(argv[1],"stdout")==0){ if(access(argv[2],W_OK)<0){ Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL); return TCL_ERROR; } Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDOUT)); channel = Tcl_OpenFileChannel(interp, argv[2], "WRONLY",0666); Tcl_RegisterChannel(interp,channel); Tcl_SetStdChannel(channel,TCL_STDOUT); } else if(strcmp(argv[1],"stderr")==0){ if(access(argv[2],W_OK)<0){ Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL); return TCL_ERROR; } Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDERR)); channel = Tcl_OpenFileChannel(interp, argv[2], "WRONLY",0666); Tcl_RegisterChannel(interp,channel); Tcl_SetStdChannel(channel,TCL_STDERR); } else if(strcmp(argv[1],"stdin")==0){ if(access(argv[2],R_OK)<0){ Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL); return TCL_ERROR; } Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDIN)); channel = Tcl_OpenFileChannel(interp, argv[2], "RDONLY",0666); Tcl_RegisterChannel(interp,channel); Tcl_SetStdChannel(channel,TCL_STDIN); } else{ Tcl_AppendResult(interp,"invalid first argument (got: ",argv[1]," )",(char *) NULL); return TCL_ERROR; } if(channel == NULL) return TCL_ERROR; return TCL_OK; }
static void Prompt( 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, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } 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; }
static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel chan; if (isPtr->prompt == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { defaultPrompt: if (isPtr->prompt == PROMPT_START) { chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != NULL) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } goto defaultPrompt; } } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_Flush(chan); } isPtr->prompt = PROMPT_NONE; }
void tclSendThread(Tcl_ThreadId thread, Tcl_Interp *interpreter, CONST char *script) { ThreadEvent *event; Tcl_Channel errorChannel; Tcl_Obj *object; int boolean; object = Tcl_GetVar2Ex(interpreter, "::tcl_platform", "threaded", 0); if ((object == 0) || (Tcl_GetBooleanFromObj(interpreter, object, &boolean) != TCL_OK) || !boolean) { errorChannel = Tcl_GetStdChannel(TCL_STDERR); if (errorChannel == NULL) return; Tcl_WriteChars( errorChannel, "error: Python thread requested script evaluation on Tcl core not compiled for multithreading.\n", -1 ); return; } event = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent)); event->event.proc = ThreadEventProc; event->interpreter = interpreter; event->script = strcpy(Tcl_Alloc(strlen(script) + 1), script); Tcl_MutexLock(&threadMutex); Tcl_ThreadQueueEvent(thread, (Tcl_Event *)event, TCL_QUEUE_TAIL); Tcl_ThreadAlert(thread); Tcl_MutexUnlock(&threadMutex); }
static void ThreadErrorProc(Tcl_Interp *interpreter) { #ifdef WIN32 /* George Petasis, 21 Feb 2006: * Unfortunatelly, I cannot find a way to measure the LONG_MAX characters * with Visual C++ preprocessor. char buffer[strlen("")] does nto seem to work * with static functions under Visual C++ .NET.*/ char buffer[15]; #else char buffer[strlen(XSTRING(LONG_MAX))]; #endif CONST char *errorInformation; Tcl_Channel errorChannel; errorInformation = Tcl_GetVar(interpreter, "errorInfo", TCL_GLOBAL_ONLY); if (errorInformation == 0) { errorInformation = ""; } errorChannel = Tcl_GetStdChannel(TCL_STDERR); if (errorChannel == NULL) return; sprintf(buffer, "%ld", (long)CURRENTTHREAD); Tcl_WriteChars(errorChannel, "Error from thread ", -1); Tcl_WriteChars(errorChannel, buffer, -1); Tcl_WriteChars(errorChannel, "\n", 1); Tcl_WriteChars(errorChannel, errorInformation, -1); Tcl_WriteChars(errorChannel, "\n", 1); }
void TnmSnmpDumpPDU(Tcl_Interp *interp, TnmSnmpPdu *pdu) { if (hexdump) { int i, code, argc; const char **argv; char *name, *status; char buffer[80]; Tcl_DString dst; Tcl_Channel channel; Tcl_DStringInit(&dst); name = TnmGetTableValue(tnmSnmpPDUTable, (unsigned) pdu->type); if (name == NULL) { name = "(unknown PDU type)"; } status = TnmGetTableValue(tnmSnmpErrorTable, (unsigned) pdu->errorStatus); if (status == NULL) { status = "(unknown error code)"; } if (pdu->type == ASN1_SNMP_GETBULK) { sprintf(buffer, "%s %d non-repeaters %d max-repetitions %d\n", name, pdu->requestId, pdu->errorStatus, pdu->errorIndex); } else if (pdu->type == ASN1_SNMP_TRAP1) { sprintf(buffer, "%s\n", name); } else if (pdu->errorStatus == TNM_SNMP_NOERROR) { sprintf(buffer, "%s %d %s\n", name, pdu->requestId, status); } else { sprintf(buffer, "%s %d %s at %d\n", name, pdu->requestId, status, pdu->errorIndex); } Tcl_DStringAppend(&dst, buffer, -1); code = Tcl_SplitList(interp, Tcl_DStringValue(&pdu->varbind), &argc, &argv); if (code == TCL_OK) { for (i = 0; i < argc; i++) { sprintf(buffer, "%4d.\t", i+1); Tcl_DStringAppend(&dst, buffer, -1); Tcl_DStringAppend(&dst, argv[i], -1); Tcl_DStringAppend(&dst, "\n", -1); } ckfree((char *) argv); } Tcl_ResetResult(interp); channel = Tcl_GetStdChannel(TCL_STDOUT); if (channel) { Tcl_Write(channel, Tcl_DStringValue(&dst), Tcl_DStringLength(&dst)); } Tcl_DStringFree(&dst); } }
rpmtcl rpmtclNew(char ** av, uint32_t flags) { rpmtcl tcl = #ifdef NOTYET (flags & 0x80000000) ? rpmtclI() : #endif rpmtclGetPool(_rpmtclPool); #if defined(WITH_TCL) static char * _av[] = { "rpmtcl", NULL }; Tcl_Interp * tclI = Tcl_CreateInterp(); char b[32]; int ac; if (av == NULL) av = _av; ac = argvCount((ARGV_t)av); Tcl_SetVar(tclI, "argv", Tcl_Merge(ac-1, (const char *const *)av+1), TCL_GLOBAL_ONLY); (void)sprintf(b, "%d", ac-1); Tcl_SetVar(tclI, "argc", b, TCL_GLOBAL_ONLY); Tcl_SetVar(tclI, "argv0", av[0], TCL_GLOBAL_ONLY); Tcl_SetVar(tclI, "tcl_interactive", "0", TCL_GLOBAL_ONLY); tcl->I = tclI; { Tcl_Channel tclout = Tcl_GetStdChannel(TCL_STDOUT); Tcl_SetChannelOption(tclI, tclout, "-translation", "auto"); Tcl_StackChannel(tclI, &rpmtclIO, tcl, TCL_WRITABLE, tclout); tcl->tclout = (void *) tclout; } #endif tcl->iob = rpmiobNew(0); return rpmtclLink(tcl); }
static void printImgInfo (RAWHEADER *th, FMTOPT *opts, const char *filename, const char *msg) { Tcl_Channel outChan; char str[256]; outChan = Tcl_GetStdChannel (TCL_STDOUT); if (!outChan) { return; } sprintf (str, "%s %s\n", msg, filename); OUT; sprintf (str, "\tSize in pixel : %d x %d\n", th->width, th->height); OUT; sprintf (str, "\tNo. of channels : %d\n", th->nChans); OUT; sprintf (str, "\tPixel type : %s\n", (th->pixelType == TYPE_FLOAT? strFloat: (th->pixelType == TYPE_USHORT? strUShort: (th->pixelType == TYPE_UBYTE? strUByte: strUnknown)))); OUT; sprintf (str, "\tVertical encoding: %s\n", th->scanOrder == TOP_DOWN? strTopDown: strBottomUp); OUT; sprintf (str, "\tGamma correction : %f\n", opts->gamma); OUT; sprintf (str, "\tMinimum map value: %f\n", opts->minVal); OUT; sprintf (str, "\tMaximum map value: %f\n", opts->maxVal); OUT; sprintf (str, "\tHost byte order : %s\n", isIntel ()? strIntel: strMotorola); OUT; sprintf (str, "\tFile byte order : %s\n", th->byteOrder == INTEL? strIntel: strMotorola); OUT; Tcl_Flush (outChan); }
static void ThreadErrorProc( Tcl_Interp *interp) /* Interp that failed */ { Tcl_Channel errChannel; const char *errorInfo, *argv[3]; char *script; char buf[TCL_DOUBLE_SPACE+1]; sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); Tcl_WriteChars(errChannel, buf, -1); Tcl_WriteChars(errChannel, "\n", 1); Tcl_WriteChars(errChannel, errorInfo, -1); Tcl_WriteChars(errChannel, "\n", 1); } else { argv[0] = errorProcString; argv[1] = buf; argv[2] = errorInfo; script = Tcl_Merge(3, argv); TclThreadSend(interp, errorThreadId, script, 0); ckfree(script); } }
static int SetupStdFile( TclFile file, /* File to dup, or NULL. */ int type) /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ { Tcl_Channel channel; int fd; int targetFd = 0; /* Initializations here needed only to */ int direction = 0; /* prevent warnings about using uninitialized * variables. */ switch (type) { case TCL_STDIN: targetFd = 0; direction = TCL_READABLE; break; case TCL_STDOUT: targetFd = 1; direction = TCL_WRITABLE; break; case TCL_STDERR: targetFd = 2; direction = TCL_WRITABLE; break; } if (!file) { channel = Tcl_GetStdChannel(type); if (channel) { file = TclpMakeFile(channel, direction); } } if (file) { fd = GetFd(file); if (fd != targetFd) { if (dup2(fd, targetFd) == -1) { return 0; } /* * Must clear the close-on-exec flag for the target FD, since some * systems (e.g. Ultrix) do not clear the CLOEXEC flag on the * target FD. */ fcntl(targetFd, F_SETFD, 0); } else { /* * Since we aren't dup'ing the file, we need to explicitly clear * the close-on-exec flag. */ fcntl(fd, F_SETFD, 0); } } else { close(targetFd); } return 1; }
void TnmWriteMessage(const char *msg) { Tcl_Channel channel; channel = Tcl_GetStdChannel(TCL_STDERR); if (channel) { Tcl_Write(channel, msg, -1); } }
static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ InteractiveState *isPtr) /* InteractiveState. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel chan; promptCmdPtr = Tcl_GetVar2Ex(interp, isPtr->gotPartial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY); if (promptCmdPtr == NULL) { defaultPrompt: if (!isPtr->gotPartial) { chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); if (Tcl_GetStringResult(interp)[0] != '\0') { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != NULL) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } goto defaultPrompt; } } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_Flush(chan); } }
void TkpDisplayWarning( CONST char *msg, /* Message to be displayed. */ CONST char *title) /* Title of warning. */ { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_WriteChars(errChannel, title, -1); Tcl_WriteChars(errChannel, ": ", 2); Tcl_WriteChars(errChannel, msg, -1); Tcl_WriteChars(errChannel, "\n", 1); } }
void Tcl_SourceRCFile( Tcl_Interp *interp) /* Interpreter to source rc file into. */ { Tcl_DString temp; const char *fileName; Tcl_Channel chan; fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); if (fullName == NULL) { /* * Couldn't translate the file name (e.g. it referred to a bogus * user or there was no HOME environment variable). Just do * nothing. */ } else { /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1); Tcl_Close(NULL, c); Tcl_IncrRefCount(fullNameObj); if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } Tcl_DecrRefCount(fullNameObj); } } Tcl_DStringFree(&temp); } }
void Tcl_SourceRCFile( Tcl_Interp *interp) /* Interpreter to source rc file into. */ { Tcl_DString temp; CONST char *fileName; Tcl_Channel errChannel; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; CONST char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); if (fullName == NULL) { /* * Couldn't translate the file name (e.g. it referred to a bogus * user or there was no HOME environment variable). Just do * nothing. */ } else { /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != (Tcl_Channel) 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); } } } } Tcl_DStringFree(&temp); } }
static void printImgInfo (TGAHEADER *th, CONST char *filename, CONST char *msg) { Tcl_Channel outChan; char str[256]; outChan = Tcl_GetStdChannel (TCL_STDOUT); if (!outChan) { return; } sprintf (str, "%s %s\n", msg, filename); OUT; sprintf (str, "\tSize in pixel : %d x %d\n", th->xsize, th->ysize); OUT; sprintf (str, "\tNo. of channels : %d\n", NCHAN(th->pixsize)); OUT; sprintf (str, "\tCompression : %s\n", IS_COMPRESSED(th->imgtyp)? "RLE": "None"); OUT; sprintf (str, "\tVertical encoding : %s\n", ENC_TOP_BOTTOM(th->imgdes)? "Top -> Bottom": "Bottom -> Top"); OUT; sprintf (str, "\tHorizontal encoding: %s\n", ENC_LEFT_RIGHT(th->imgdes)? "Left -> Right": "Right -> Left"); OUT; Tcl_Flush (outChan); }
int Tk_CreateConsoleWindow( Tcl_Interp *interp) /* Interpreter to use for prompting. */ { Tcl_Channel chan; ConsoleInfo *info; Tk_Window mainWindow; Tcl_Command token; int result = TCL_OK; int haveConsoleChannel = 1; /* Init an interp with Tcl and Tk */ Tcl_Interp *consoleInterp = Tcl_CreateInterp(); if (Tcl_Init(consoleInterp) != TCL_OK) { goto error; } if (Tk_Init(consoleInterp) != TCL_OK) { goto error; } /* * Fetch the instance data from whatever std channel is a * console channel. If none, create fresh instance data. */ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN)) == &consoleChannelType) { } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT)) == &consoleChannelType) { } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR)) == &consoleChannelType) { } else { haveConsoleChannel = 0; } if (haveConsoleChannel) { ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan); info = data->info; if (info->consoleInterp) { /* New ConsoleInfo for a new console window */ info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo)); info->refCount = 0; /* Update any console channels to make use of the new console */ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN)) == &consoleChannelType) { data = (ChannelData *) Tcl_GetChannelInstanceData(chan); data->info->refCount--; data->info = info; data->info->refCount++; } if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT)) == &consoleChannelType) { data = (ChannelData *) Tcl_GetChannelInstanceData(chan); data->info->refCount--; data->info = info; data->info->refCount++; } if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR)) == &consoleChannelType) { data = (ChannelData *) Tcl_GetChannelInstanceData(chan); data->info->refCount--; data->info = info; data->info->refCount++; } } } else { info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo)); info->refCount = 0; } info->consoleInterp = consoleInterp; info->interp = interp; Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info); info->refCount++; Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp); /* * Add console commands to the interp */ token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info, ConsoleDeleteProc); info->refCount++; /* * We don't have to count the ref held by the [consoleinterp] command * in the consoleInterp. The ref held by the consoleInterp delete * handler takes care of us. */ Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd, info, NULL); mainWindow = Tk_MainWindow(interp); if (mainWindow) { Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc, info); info->refCount++; } Tcl_Preserve(consoleInterp); result = Tcl_GlobalEval(consoleInterp, "source $tk_library/console.tcl"); if (result == TCL_ERROR) { Tcl_SetReturnOptions(interp, Tcl_GetReturnOptions(consoleInterp, result)); Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp)); } Tcl_Release(consoleInterp); if (result == TCL_ERROR) { Tcl_DeleteCommandFromToken(interp, token); mainWindow = Tk_MainWindow(interp); if (mainWindow) { Tk_DeleteEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc, info); if (--info->refCount <= 0) { ckfree((char *) info); } } goto error; } return TCL_OK; error: Tcl_AddErrorInfo(interp, "\n (creating console window)"); if (!Tcl_InterpDeleted(consoleInterp)) { Tcl_DeleteInterp(consoleInterp); } return TCL_ERROR; }
static int ShouldUseConsoleChannel( int type) { DWORD handleId; /* Standard handle to retrieve. */ DCB dcb; DWORD consoleParams; DWORD fileType; int mode; const char *bufMode; HANDLE handle; switch (type) { case TCL_STDIN: handleId = STD_INPUT_HANDLE; mode = TCL_READABLE; bufMode = "line"; break; case TCL_STDOUT: handleId = STD_OUTPUT_HANDLE; mode = TCL_WRITABLE; bufMode = "line"; break; case TCL_STDERR: handleId = STD_ERROR_HANDLE; mode = TCL_WRITABLE; bufMode = "none"; break; default: return 0; break; } handle = GetStdHandle(handleId); /* * Note that we need to check for 0 because Windows will return 0 if this * is not a console mode application, even though this is not a valid * handle. */ if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) { return 1; } /* * Win2K BUG: GetStdHandle(STD_OUTPUT_HANDLE) can return what appears to * be a valid handle. See TclpGetDefaultStdChannel() for this change * implemented. We didn't change it here because GetFileType() [below] * will catch this with FILE_TYPE_UNKNOWN and appropriately return a value * of 1, anyways. * * char dummyBuff[1]; * DWORD dummyWritten; * * if ((type == TCL_STDOUT) * && !WriteFile(handle, dummyBuff, 0, &dummyWritten, NULL)) { * return 1; * } */ fileType = GetFileType(handle); /* * If the file is a character device, we need to try to figure out whether * it is a serial port, a console, or something else. We test for the * console case first because this is more common. */ if (fileType == FILE_TYPE_CHAR) { dcb.DCBlength = sizeof(DCB); if (!GetConsoleMode(handle, &consoleParams) && !GetCommState(handle, &dcb)) { /* * Don't use a CHAR type channel for stdio, otherwise Tk runs into * trouble with the MS DevStudio debugger. */ return 1; } } else if (fileType == FILE_TYPE_UNKNOWN) { return 1; } else if (Tcl_GetStdChannel(type) == NULL) { return 1; } return 0; }
TclInterpreter::TclInterpreter(int argc, char **argv) :wrapper(), cmds(this) { /* fmk - beginning of modifications for OpenSees */ fprintf(stderr,"\n\n\t OpenSees -- Open System For Earthquake Engineering Simulation"); fprintf(stderr,"\n\tPacific Earthquake Engineering Research Center -- 3.0.0\n\n"); fprintf(stderr,"\t (c) Copyright 1999,2000 The Regents of the University of California"); fprintf(stderr,"\n\t\t\t\t All Rights Reserved\n"); fprintf(stderr," (Copyright and Disclaimer @ http://www.berkeley.edu/OpenSees/copyright.html)\n\n\n"); Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); #endif /* * 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 (tclStartupScriptFileName == NULL) { if ((argc > 1) && (argv[1][0] != '-')) { tclStartupScriptFileName = argv[1]; argc--; argv++; } } args = Tcl_Merge(argc-1, argv+1); Tcl_ExternalToUtfDString(NULL, args, -1, &argString); Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); Tcl_DStringFree(&argString); ckfree(args); if (tclStartupScriptFileName == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); } else { tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL, tclStartupScriptFileName, -1, &argString); } TclFormatInt(buffer, argc-1); Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); char one[2] = "1"; char zero[2] = "0"; Tcl_SetVar(interp, "tcl_interactive", ((tclStartupScriptFileName == NULL) && tty) ? one : zero, TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ #ifndef TCL_LOCAL_APPINIT #define TCL_LOCAL_APPINIT Tcl_AppInit #endif if ((*Tcl_AppInit)(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); } } wrapper.addOpenSeesCommands(interp); }
/* ARGSUSED */ int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName * call). Additional arguments have not been * converted. */ TclFile inputFile, /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is * not readable or is NULL, the child will * receive no standard input. */ TclFile outputFile, /* If non-NULL, gives the file that receives * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ TclFile errorFile, /* If non-NULL, gives the file that receives * errors from the child process. If errorFile * file is not writeable or is NULL, errors * from the child will be discarded. errorFile * may be the same as outputFile. */ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is * filled with the process id of the child * process. */ { TclFile errPipeIn, errPipeOut; int count, status, fd; char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; int pid, i; errPipeIn = NULL; errPipeOut = NULL; pid = -1; /* * Create a pipe that the child can use to return error information if * anything goes wrong. */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), NULL); goto error; } /* * We need to allocate and convert this before the fork so it is properly * deallocated later */ dsArray = (Tcl_DString *) TclStackAlloc(interp, argc * sizeof(Tcl_DString)); newArgv = (char **) TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); } #ifdef USE_VFORK /* * After vfork(), do not call code in the child that changes global state, * because it is using the parent's memory space at that point and writes * might corrupt the parent: so ensure standard channels are initialized in * the parent, otherwise SetupStdFile() might initialize them in the child. */ if (!inputFile) { Tcl_GetStdChannel(TCL_STDIN); } if (!outputFile) { Tcl_GetStdChannel(TCL_STDOUT); } if (!errorFile) { Tcl_GetStdChannel(TCL_STDERR); } #endif pid = fork(); if (pid == 0) { int joinThisError = errorFile && (errorFile == outputFile); fd = GetFd(errPipeOut); /* * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, "%dforked process couldn't set up input/output: ", errno); (void)write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } /* * Close the input side of the error pipe. */ RestoreSignals(); execvp(newArgv[0], newArgv); /* INTL: Native. */ sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); (void)write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } /* * Free the mem we used for the fork */ for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } TclStackFree(interp, newArgv); TclStackFree(interp, dsArray); if (pid == -1) { Tcl_AppendResult(interp, "couldn't fork child process: ", Tcl_PosixError(interp), NULL); goto error; } /* * Read back from the error pipe to see if the child started up OK. The * info in the pipe (if any) consists of a decimal errno value followed by * an error message. */ TclpCloseFile(errPipeOut); errPipeOut = NULL; fd = GetFd(errPipeIn); count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; errSpace[count] = 0; errno = strtol(errSpace, &end, 10); Tcl_AppendResult(interp, end, Tcl_PosixError(interp), NULL); goto error; } TclpCloseFile(errPipeIn); *pidPtr = (Tcl_Pid) INT2PTR(pid); return TCL_OK; error: if (pid != -1) { /* * Reap the child process now if an error occurred during its startup. * We don't call this with WNOHANG because that can lead to defunct * processes on an MP system. We shouldn't have to worry about hanging * here, since this is the error case. [Bug: 6148] */ Tcl_WaitPid((Tcl_Pid) INT2PTR(pid), &status, 0); } if (errPipeIn) { TclpCloseFile(errPipeIn); } if (errPipeOut) { TclpCloseFile(errPipeOut); } return TCL_ERROR; }
int TclInterpreter::run() { /* * If a script file was specified then just source that file * and quit. */ if (tclStartupScriptFileName != NULL) { code = Tcl_EvalFile(interp, tclStartupScriptFileName); 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; } return 0; } else { /* const char *pwd = getInterpPWD(interp); simulationInfo.start(); simulationInfo.addInputFile(tclStartupScriptFileName, pwd); */ /* * We're running interactively. Source a user-specific startup * file if the application specified one and if the file exists. */ Tcl_DStringFree(&argString); 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. */ /* if (simulationInfoOutputFilename != 0) { simulationInfo.start(); } */ commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); gotPartial = 0; while (1) { if (tty) { Tcl_Obj *promptCmdPtr; char one[12] = "tcl_prompt1"; char two[12] = "tcl_prompt2"; promptCmdPtr = Tcl_GetVar2Ex(interp, (gotPartial ? one : two), NULL, TCL_GLOBAL_ONLY); if (promptCmdPtr == NULL) { defaultPrompt: if (!gotPartial && outChannel) { Tcl_WriteChars(outChannel, "OpenSees > ", 11); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, 0); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (code != TCL_OK) { if (errChannel) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); goto defaultPrompt; } } if (outChannel) { Tcl_Flush(outChannel); } } if (!inChannel) { return 0; // goto done; } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { return 0; //goto done; } if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { return 0; // goto done; } /* * Add the newline removed by Tcl_GetsObj back to the string. */ Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { gotPartial = 1; continue; } gotPartial = 0; code = Tcl_RecordAndEvalObj(interp, commandPtr, 0); 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_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } } #ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_DecrRefCount(commandPtr); Tcl_DeleteInterp(interp); Tcl_Exit(0); } #endif } } return 0; }
/* ARGSUSED */ static void 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; 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, 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; Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* * 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, 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 != NULL) { Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); } if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != NULL) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } /* * If a tty stdin is still around, output a prompt. */ prompt: if (isPtr->tty && (isPtr->input != NULL)) { Prompt(interp, isPtr); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } }
void Tcl_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ Tcl_Interp *interp) { Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; Tcl_Channel chan; InteractiveState is; TclpSetInitialEncodings(); TclpFindExecutable((const char *)argv[0]); 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 * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != 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) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { appName = NewNativeObj(argv[0], -1); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteChars(chan, "application-specific initialization failed: ", -1); Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } 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 * 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) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_WriteObj(chan, valuePtr); } Tcl_WriteChars(chan, "\n", 1); Tcl_DecrRefCount(options); } 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); if (Tcl_LimitExceeded(interp)) { goto done; } /* * 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. */ Tcl_IncrRefCount(is.commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ 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) { int length; if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } is.input = Tcl_GetStdChannel(TCL_STDIN); if (is.input == NULL) { break; } } if (Tcl_IsShared(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); if (length < 0) { 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. * 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. Have * to add it back before testing completeness, because it can make * a difference. [Bug 1775878] */ if (Tcl_IsShared(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } Tcl_AppendToObj(is.commandPtr, "\n", 1); if (!TclObjCommandComplete(is.commandPtr)) { is.prompt = PROMPT_CONTINUE; continue; } 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(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) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\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. */ if (is.input) { if (is.tty) { Prompt(interp, &is); } Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); } mainLoopProc(); Tcl_SetMainLoop(NULL); if (is.input) { Tcl_DeleteChannelHandler(is.input, StdinProc, &is); } is.input = Tcl_GetStdChannel(TCL_STDIN); } /* * 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 /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); 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 * this point. */ mainLoopProc(); Tcl_SetMainLoop(NULL); } if (is.commandPtr != NULL) { Tcl_DecrRefCount(is.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_EvalObjEx call should never return. */ 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); } /* * 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_Exit(exitCode); }
/* ** This routine runs first. */ int main(int argc, char **argv){ Tcl_Interp *interp; char *args; char buf[100]; int tty; char TCLdir[20]; char TKdir[20]; char autopath[20]; char sourceCmd[80]; #ifdef WITHOUT_TK Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; char buffer[1000]; int code, gotPartial, length; Tcl_Channel inChannel, outChannel, errChannel; #endif /* Create a Tcl interpreter */ Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); if( Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1)==0 ){ return 1; } args = Tcl_Merge(argc-1, (CONST84 char * CONST *)argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buf, "%d", argc-1); Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", argv[0], TCL_GLOBAL_ONLY); tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* We have to initialize the virtual filesystem before calling ** Tcl_Init(). Otherwise, Tcl_Init() will not be able to find ** its startup script files. */ Zvfs_Init(interp); Tcl_SetVar(interp, "extname", "", TCL_GLOBAL_ONLY); Zvfs_Mount(interp, (char *)Tcl_GetNameOfExecutable(), "/"); sprintf(TCLdir, "%s/tcl", mountPt); Tcl_SetVar2(interp, "env", "TCL_LIBRARY", TCLdir, TCL_GLOBAL_ONLY); sprintf(TKdir, "%s/tk", mountPt); Tcl_SetVar2(interp, "env", "TK_LIBRARY", TKdir, TCL_GLOBAL_ONLY); /* Initialize Tcl and Tk */ if( Tcl_Init(interp) ) return TCL_ERROR; sprintf(autopath, " %s", TCLdir); Tcl_SetVar(interp, "auto_path", autopath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_libPath", TCLdir, TCL_GLOBAL_ONLY); #ifdef WITHOUT_TK Tcl_SetVar(interp, "extname", "tclsh", TCL_GLOBAL_ONLY); #else Tk_InitConsoleChannels(interp); if ( Tk_Init(interp) ) { return TCL_ERROR; } Tcl_StaticPackage(interp,"Tk", Tk_Init, 0); Tk_CreateConsoleWindow(interp); #endif /* Start up all extensions. */ #if defined(__WIN32__) /* DRL - Do the standard Windows extentions */ if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Registry", Registry_Init, 0); if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Dde", Dde_Init, 0); #endif #ifndef WITHOUT_TDOM if (Tdom_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tdom", Tdom_Init, Tdom_SafeInit); #endif #ifndef WITHOUT_TLS if (Tls_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tls", Tls_Init, Tls_SafeInit); #endif /* #ifndef WITHOUT_MKZIPLIB if (Mkziplib_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Mkziplib", Mkziplib_Init, Mkziplib_SafeInit); #endif */ #ifndef WITHOUT_XOTCL if (Xotcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Xotcl", Xotcl_Init, Xotcl_SafeInit); /* if (Xotclexpat_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "xotclexpat", Xotclexpat_Init, 0); */ /* if (Xotclsdbm_Init(interp) == TCL_ERROR) { return TCL_ERROR; } */ // Tcl_StaticPackage(interp, "xotclsdbm", Xotclsdbm_Init, Xotclsdbm_SafeInit); /* if (Xotclgdbm_Init(interp) == TCL_ERROR) { return TCL_ERROR; } */ // Tcl_StaticPackage(interp, "xotclgdbm", Xotclgdbm_Init, Xotclgdbm_SafeInit); #endif #ifndef WITHOUT_TGDBM if (Tgdbm_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tgdbm", Tgdbm_Init, 0); #endif #ifndef WITHOUT_THREAD if (Thread_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Thread", Thread_Init, 0); #endif #if !defined(WITHOUT_TK) && !defined(WITHOUT_WINICO) && (defined(__WIN32__) || defined(_WIN32)) if (Winico_Init(interp) == TCL_ERROR) return TCL_ERROR; Tcl_StaticPackage(interp, "Winico", Winico_Init, Winico_SafeInit); #endif /* Add some freeWrap commands */ if (Freewrap_Init(interp) == TCL_ERROR) return TCL_ERROR; /* After all extensions are registered, start up the ** program by running freewrapCmds.tcl. */ sprintf(sourceCmd, "source %s/freewrapCmds.tcl", mountPt); Tcl_Eval(interp, sourceCmd); #ifndef WITHOUT_TK /* * Loop infinitely, waiting for commands to execute. When there * are no windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); Tcl_DeleteInterp(interp); Tcl_Exit(0); #else /* * 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); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); gotPartial = 0; while (1) { if (tty) { Tcl_Obj *promptCmdPtr; promptCmdPtr = Tcl_GetVar2Ex(interp, (gotPartial ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (promptCmdPtr == NULL) { defaultPrompt: if (!gotPartial && outChannel) { Tcl_WriteChars(outChannel, "% ", 2); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, 0); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (code != TCL_OK) { if (errChannel) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); goto defaultPrompt; } } if (outChannel) { Tcl_Flush(outChannel); } } if (!inChannel) { goto done; } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { goto done; } if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { goto done; } /* * Add the newline removed by Tcl_GetsObj back to the string. */ Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { gotPartial = 1; continue; } gotPartial = 0; code = Tcl_RecordAndEvalObj(interp, commandPtr, 0); 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_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } } } /* * 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. */ done: if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } sprintf(buffer, "exit %d", 0); Tcl_Eval(interp, buffer); #endif return TCL_OK; }
void Tcl_Main( int argc, /* Number of arguments. */ 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_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; const char *encodingName = NULL; PromptType prompt = PROMPT_START; int code, length, tty, exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString appName; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) && ('-' != argv[3][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { const char *pathName = Tcl_GetStringFromObj(path, &length); Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); Tcl_SetStartupScript(path, encodingName); } Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); Tcl_DStringFree(&appName); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); 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_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(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 (Tcl_LimitExceeded(interp)) { goto done; } /* * If a script file was specified then just source that file and quit. * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); } 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); if (Tcl_LimitExceeded(interp)) { goto done; } /* * 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 != NULL) && !Tcl_InterpDeleted(interp)) { if (mainLoopProc == NULL) { if (tty) { Prompt(interp, &prompt); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == 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. Have * to add it back before testing completeness, because it can make * a difference. [Bug 1775878] */ 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; /* * 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); 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(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); } 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 != NULL) { Tcl_DeleteChannelHandler(isPtr->input, StdinProc, 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) && !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 * 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_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); } } Tcl_SetStartupScript(NULL, NULL); /* * If we get here, the master interp has been deleted. Allow its * destruction with the last matching Tcl_Release. */ Tcl_Release(interp); Tcl_Exit(exitCode); }
void Tk_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ Tcl_Interp *interp) { Tcl_Obj *path, *argvPtr, *appName; const char *encodingName; int code, nullStdin = 0; Tcl_Channel chan; InteractiveState is; /* * Ensure that we are getting a compatible version of Tcl. This is really * only an issue when Tk is loaded dynamically. */ if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { abort(); } #if defined(__WIN32__) && !defined(__WIN64__) && !defined(UNICODE) && !defined(STATIC_BUILD) if (tclStubsPtr->reserved9) { /* We are running win32 Tk under Cygwin, so let's check * whether the env("DISPLAY") variable or the -display * argument is set. If so, we really want to run the * Tk_MainEx function of libtk8.?.dll, not this one. */ if (Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY)) { loadCygwinTk: if (TkCygwinMainEx(argc, argv, appInitProc, interp)) { /* Should never reach here. */ return; } } else { int i; for (i = 1; i < argc; ++i) { if (!_tcscmp(argv[i], TEXT("-display"))) { goto loadCygwinTk; } } } } #endif Tcl_InitMemory(interp); is.interp = interp; is.gotPartial = 0; Tcl_Preserve(interp); #if defined(__WIN32__) && !defined(__CYGWIN__) Tk_InitConsoleChannels(interp); #endif #ifdef MAC_OSX_TK if (Tcl_GetStartupScript(NULL) == NULL) { TkMacOSXDefaultStartupScript(); } #endif /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { size_t length; /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME * or like * -file FILENAME (ancient history support only) */ 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)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; } else if ((argc > 1) && (TEXT('-') != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } else if ((argc > 2) && (length = _tcslen(argv[1])) && (length > 1) && (0 == _tcsncmp(TEXT("-file"), argv[1], length)) && (TEXT('-') != argv[2][0])) { Tcl_SetStartupScript(NewNativeObj(argv[2], -1), NULL); argc -= 2; argv += 2; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { appName = NewNativeObj(argv[0], -1); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ is.tty = isatty(0); #if defined(MAC_OSX_TK) /* * On TkAqua, if we don't have a TTY and stdin is a special character file * of length 0, (e.g. /dev/null, which is what Finder sets when double * clicking Wish) then use the GUI console. */ if (!is.tty) { struct stat st; nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks); } #endif Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(!path && (is.tty || nullStdin)), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ if (appInitProc(interp) != TCL_OK) { TkpDisplayWarning(Tcl_GetStringResult(interp), "application-specific initialization failed"); } /* * 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) { /* * The following statement guarantees that the errorInfo variable * is set properly. */ Tcl_AddErrorInfo(interp, ""); TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), "Error in startup script"); Tcl_DeleteInterp(interp); Tcl_Exit(1); } is.tty = 0; } else { /* * Evaluate the .rc file, if one has been specified. */ Tcl_SourceRCFile(interp); /* * Establish a channel handler for stdin. */ is.input = Tcl_GetStdChannel(TCL_STDIN); if (is.input) { Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); } if (is.tty) { Prompt(interp, &is); } } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan) { Tcl_Flush(chan); } Tcl_DStringInit(&is.command); Tcl_DStringInit(&is.line); Tcl_ResetResult(interp); /* * Loop infinitely, waiting for commands to execute. When there are no * windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); Tcl_DeleteInterp(interp); Tcl_Release(interp); Tcl_SetStartupScript(NULL, NULL); Tcl_Exit(0); }
int TclTextInterp::evalString(const char *s) { #if defined(VMD_NANOHUB) if (Tcl_Eval(interp, s) != TCL_OK) { #else if (Tcl_RecordAndEval(interp, s, 0) != TCL_OK) { #endif // Don't print error message if there's nothing to show. if (strlen(Tcl_GetStringResult(interp))) msgErr << Tcl_GetStringResult(interp) << sendmsg; return FALSE; } return TRUE; } void TclTextInterp::setString(const char *name, const char *val) { if (interp) Tcl_SetVar(interp, name, val, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); } void TclTextInterp::setMap(const char *name, const char *key, const char *val) { if (interp) Tcl_SetVar2(interp, name, key, val, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); } // There's a fair amount of code duplication between doEvent and evalFile, // maybe these could be combined somehow, say by having TclTextInterp keep // track of its Tcl_Channel objects. // // Side note: Reading line-by-line gives different Tcl semantics than // just calling Tcl_EvalFile. Shell commands (e.g., stty) are properly // parsed when read line-by-line and passed to Tcl_RecordAndEval, but are // unrecognized when contained in a file read by Tcl_EvalFile. I would // consider this a bug. int TclTextInterp::evalFile(const char *fname) { Tcl_Channel inchannel = Tcl_OpenFileChannel(interp, fname, "r", 0644); Tcl_Channel outchannel = Tcl_GetStdChannel(TCL_STDOUT); if (inchannel == NULL) { msgErr << "Error opening file " << fname << sendmsg; msgErr << Tcl_GetStringResult(interp) << sendmsg; return 1; } Tcl_Obj *cmdPtr = Tcl_NewObj(); Tcl_IncrRefCount(cmdPtr); int length = 0; while ((length = Tcl_GetsObj(inchannel, cmdPtr)) >= 0) { Tcl_AppendToObj(cmdPtr, "\n", 1); char *stringrep = Tcl_GetStringFromObj(cmdPtr, NULL); if (!Tcl_CommandComplete(stringrep)) { continue; } // check if "exit" was called if (app->exitFlag) break; #if defined(VMD_NANOHUB) Tcl_EvalObjEx(interp, cmdPtr, 0); #else Tcl_RecordAndEvalObj(interp, cmdPtr, 0); #endif #if TCL_MINOR_VERSION >= 4 Tcl_DecrRefCount(cmdPtr); cmdPtr = Tcl_NewObj(); Tcl_IncrRefCount(cmdPtr); #else // XXX this crashes Tcl 8.5.[46] with an internal panic Tcl_SetObjLength(cmdPtr, 0); #endif // XXX this makes sure the display is updated // after each line read from the file or pipe // So, this is also where we'd optimise reading multiple // lines at once // // In VR modes (CAVE, FreeVR, VR Juggler) the draw method will // not be called from app->display_update(), so multiple lines // of input could be combined in one frame, if possible app->display_update(); Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); char *bytes = Tcl_GetStringFromObj(resultPtr, &length); #if defined(VMDTKCON) if (length > 0) { vmdcon_append(VMDCON_ALWAYS, bytes,length); vmdcon_append(VMDCON_ALWAYS, "\n", 1); } vmdcon_purge(); #else if (length > 0) { #if TCL_MINOR_VERSION >= 4 Tcl_WriteChars(outchannel, bytes, length); Tcl_WriteChars(outchannel, "\n", 1); #else Tcl_Write(outchannel, bytes, length); Tcl_Write(outchannel, "\n", 1); #endif } Tcl_Flush(outchannel); #endif } Tcl_Close(interp, inchannel); Tcl_DecrRefCount(cmdPtr); return 0; }
void TclTextInterp::doEvent() { if (!done_waiting()) return; // no recursive calls to TclEvalObj; this prevents // display update ui from messing up Tcl. if (callLevel) return; Tcl_Channel inChannel = Tcl_GetStdChannel(TCL_STDIN); Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (needPrompt && consoleisatty) { #if TCL_MINOR_VERSION >= 4 if (gotPartial) { Tcl_WriteChars(outChannel, "? ", -1); } else { Tcl_WriteChars(outChannel, VMD_CMD_PROMPT, -1); } #else if (gotPartial) { Tcl_Write(outChannel, "? ", -1); } else { Tcl_Write(outChannel, VMD_CMD_PROMPT, -1); } #endif #if defined(VMDTKCON) vmdcon_purge(); #endif Tcl_Flush(outChannel); needPrompt = 0; } #if defined(VMD_NANOHUB) return; #endif // // MPI builds of VMD cannot try to read any command input from the // console because it creates shutdown problems, at least with MPICH. // File-based command input is fine however. // // For the time being, the Android builds won't attempt to get any // console input. Any input we're going to get is going to come via // some means other than stdin, such as a network socket, text box, etc. // if (ignorestdin) return; if (!vmd_check_stdin()) return; // // event loop based on tclMain.c // // According to the Tcl docs, GetsObj returns -1 on error or EOF. int length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_Eof(inChannel)) { // exit if we're not a tty, or if eofexit is set if ((!consoleisatty) || app->get_eofexit()) app->VMDexit("", 0, 0); } else { msgErr << "Error reading Tcl input: " << Tcl_ErrnoMsg(Tcl_GetErrno()) << sendmsg; } return; } needPrompt = 1; // add the newline removed by Tcl_GetsObj Tcl_AppendToObj(commandPtr, "\n", 1); char *stringrep = Tcl_GetStringFromObj(commandPtr, NULL); if (!Tcl_CommandComplete(stringrep)) { gotPartial = 1; return; } gotPartial = 0; callLevel++; #if defined(VMD_NANOHUB) Tcl_EvalObjEx(interp, commandPtr, 0); #else Tcl_RecordAndEvalObj(interp, commandPtr, 0); #endif callLevel--; #if TCL_MINOR_VERSION >= 4 Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); #else // XXX this crashes Tcl 8.5.[46] with an internal panic Tcl_SetObjLength(commandPtr, 0); #endif // if ok, send to stdout; if not, send to stderr Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); char *bytes = Tcl_GetStringFromObj(resultPtr, &length); #if defined(VMDTKCON) if (length > 0) { vmdcon_append(VMDCON_ALWAYS, bytes,length); vmdcon_append(VMDCON_ALWAYS, "\n", 1); } vmdcon_purge(); #else if (length > 0) { #if TCL_MINOR_VERSION >= 4 Tcl_WriteChars(outChannel, bytes, length); Tcl_WriteChars(outChannel, "\n", 1); #else Tcl_Write(outChannel, bytes, length); Tcl_Write(outChannel, "\n", 1); #endif } Tcl_Flush(outChannel); #endif }
/* ARGSUSED */ static void StdinProc( ClientData clientData, /* The state of interactive cmd line */ int mask) /* Not used. */ { char *cmd; int code, count; InteractiveState *isPtr = clientData; Tcl_Channel chan = isPtr->input; Tcl_Interp *interp = isPtr->interp; count = Tcl_Gets(chan, &isPtr->line); if (count < 0 && !isPtr->gotPartial) { if (isPtr->tty) { Tcl_Exit(0); } else { Tcl_DeleteChannelHandler(chan, StdinProc, isPtr); } return; } Tcl_DStringAppend(&isPtr->command, Tcl_DStringValue(&isPtr->line), -1); cmd = Tcl_DStringAppend(&isPtr->command, "\n", -1); Tcl_DStringFree(&isPtr->line); if (!Tcl_CommandComplete(cmd)) { isPtr->gotPartial = 1; goto prompt; } isPtr->gotPartial = 0; /* * 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, isPtr); code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); if (isPtr->input) { Tcl_CreateChannelHandler(isPtr->input, TCL_READABLE, StdinProc, isPtr); } Tcl_DStringFree(&isPtr->command); if (Tcl_GetStringResult(interp)[0] != '\0') { if ((code != TCL_OK) || (isPtr->tty)) { chan = Tcl_GetStdChannel((code != TCL_OK) ? TCL_STDERR : TCL_STDOUT); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } } /* * If a tty stdin is still around, output a prompt. */ prompt: if (isPtr->tty && (isPtr->input != NULL)) { Prompt(interp, isPtr); } Tcl_ResetResult(interp); }