int Tcl_CreatePipe( Tcl_Interp *interp, /* Errors returned in result. */ Tcl_Channel *rchan, /* Returned read side. */ Tcl_Channel *wchan, /* Returned write side. */ int flags) /* Reserved for future use. */ { int fileNums[2]; if (pipe(fileNums) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s", Tcl_PosixError(interp))); return TCL_ERROR; } fcntl(fileNums[0], F_SETFD, FD_CLOEXEC); fcntl(fileNums[1], F_SETFD, FD_CLOEXEC); *rchan = Tcl_MakeFileChannel(INT2PTR(fileNums[0]), TCL_READABLE); Tcl_RegisterChannel(interp, *rchan); *wchan = Tcl_MakeFileChannel(INT2PTR(fileNums[1]), TCL_WRITABLE); Tcl_RegisterChannel(interp, *wchan); return TCL_OK; }
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 int cmd_rechan(ClientData cd_, Tcl_Interp* ip_, int objc_, Tcl_Obj*const* objv_) { ReflectingChannel *rc; int mode; char buffer [20]; if (objc_ != 3) { Tcl_WrongNumArgs(ip_, 1, objv_, "command mode"); return TCL_ERROR; } if (Tcl_ListObjLength(ip_, objv_[1], &mode) == TCL_ERROR || Tcl_GetIntFromObj(ip_, objv_[2], &mode) == TCL_ERROR) return TCL_ERROR; Tcl_MutexLock(&rechanMutex); sprintf(buffer, "rechan%d", ++mkChanSeq); Tcl_MutexUnlock(&rechanMutex); rc = rcCreate (ip_, objv_[1], mode, buffer); rc->_chan = Tcl_CreateChannel(&reChannelType, buffer, (ClientData) rc, mode); Tcl_RegisterChannel(ip_, rc->_chan); Tcl_SetChannelOption(ip_, rc->_chan, "-buffering", "none"); Tcl_SetChannelOption(ip_, rc->_chan, "-blocking", "0"); Tcl_SetResult(ip_, buffer, TCL_VOLATILE); return TCL_OK; }
/* * Create and register a new channel for the connection */ void PgSetConnectionId(Tcl_Interp *interp, PGconn *conn) { Tcl_Channel conn_chan; Pg_ConnectionId *connid; int i; connid = (Pg_ConnectionId *) ckalloc(sizeof(Pg_ConnectionId)); connid->conn = conn; connid->res_count = 0; connid->res_last = -1; connid->res_max = RES_START; connid->res_hardmax = RES_HARD_MAX; connid->res_copy = -1; connid->res_copyStatus = RES_COPY_NONE; connid->results = (PGresult **) ckalloc(sizeof(PGresult *) * RES_START); for (i = 0; i < RES_START; i++) connid->results[i] = NULL; connid->notify_list = NULL; connid->notifier_running = 0; sprintf(connid->id, "pgsql%d", PQsocket(conn)); #if TCL_MAJOR_VERSION >= 8 connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData) PQsocket(conn)); Tcl_RegisterChannel(NULL, connid->notifier_channel); #else connid->notifier_socket = -1; #endif #if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION == 5 /* Original signature (only seen in Tcl 7.5) */ conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, NULL, NULL, (ClientData) connid); #else /* Tcl 7.6 and later use this */ conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid, TCL_READABLE | TCL_WRITABLE); #endif Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line"); Tcl_SetResult(interp, connid->id, TCL_VOLATILE); Tcl_RegisterChannel(interp, conn_chan); }
/* *---------------------------------------------------------------------- * * Tcl_CreatePipe -- * * System dependent interface to create a pipe for the [chan pipe] * command. Stolen from TclX. * * Parameters: * o interp - Errors returned in result. * o rchan, wchan - Returned read and write side. * o flags - Reserved for future use. * Results: * TCL_OK or TCL_ERROR. * *---------------------------------------------------------------------- */ int Tcl_CreatePipe( Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags) { int fileNums[2]; if (pipe(fileNums) < 0) { Tcl_AppendResult(interp, "pipe creation failed: ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } *rchan = Tcl_MakeFileChannel((ClientData) INT2PTR(fileNums[0]), TCL_READABLE); Tcl_RegisterChannel(interp, *rchan); *wchan = Tcl_MakeFileChannel((ClientData) INT2PTR(fileNums[1]), TCL_WRITABLE); Tcl_RegisterChannel(interp, *wchan); return TCL_OK; }
void TnmCreateSocketHandler(int sock, int mask, TnmSocketProc *proc, ClientData clientData) { SocketHandler *shPtr; shPtr = (SocketHandler *) ckalloc(sizeof(SocketHandler)); shPtr->sd = sock; shPtr->channel = Tcl_MakeTcpClientChannel((ClientData) sock); shPtr->proc = proc; shPtr->clientData = clientData; Tcl_RegisterChannel((Tcl_Interp *) NULL, shPtr->channel); Tcl_CreateChannelHandler(shPtr->channel, mask, proc, clientData); shPtr->nextPtr = socketHandlerList; socketHandlerList = shPtr; }
/*----------------------------------------------------------------------------- * BindFileHandles -- * * Bind the file handles for a socket to one or two Tcl file channels. * Binding to two handles is for compatibility with older interfaces. * If an error occurs, both file descriptors will be closed and cleaned up. * * Parameters: * o interp (O) - File handles or error messages are return in result. * o options (I) - Options set controling buffering and handle allocation: * o SERVER_BUF - Two file handle buffering. * o SERVER_NOBUF - No buffering. * o socketFD (I) - File number of the socket that was opened. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int BindFileHandles (Tcl_Interp *interp, unsigned options, int socketFD) { Tcl_Channel channel; channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD); Tcl_RegisterChannel (interp, channel); if (options & SERVER_NOBUF) { if (TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING, TCLX_BUFFERING_NONE) == TCL_ERROR) goto errorExit; } Tcl_AppendElement (interp, Tcl_GetChannelName (channel)); return TCL_OK; errorExit: CloseForError (interp, channel, socketFD); return TCL_ERROR; }
int sequencer_make_channel(ClientData clientData, Tcl_Interp *interp, snd_sequencer_t *sequencer, int direction) { if (snd_sequencer_poll_descriptors_count(sequencer) != 1) { Tcl_AppendResult(interp, "sequencer device needs more than one file descriptor", NULL); snd_sequencer_close(sequencer); return TCL_ERROR; } sequencer_instance_t *sqi = (sequencer_instance_t *)ckalloc(sizeof(sequencer_instance_t)); char channel_name[256]; snprintf(channel_name, sizeof(channel_name), "sequencer@%s", snd_sequencer_name(sequencer)); sqi->direction = direction; sqi->sequencer = sequencer; struct pollfd pollfd; snd_sequencer_poll_descriptors(sqi->sequencer, &pollfd, 1); sqi->fd = pollfd.fd; sqi->chan = Tcl_CreateChannel(&sequencer_channel_type, channel_name, sqi, direction); if (sqi->chan == NULL) { ckfree((char *)sqi); snd_sequencer_close(sequencer); return TCL_ERROR; } Tcl_RegisterChannel(interp, sqi->chan); Tcl_AppendResult(interp, channel_name, NULL); return TCL_OK; }
int Tcl_SocketObjCmd( ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *socketOptions[] = { "-async", "-myaddr", "-myport","-server", NULL }; enum socketOptions { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; int optionIndex, a, server = 0, port, myport = 0, async = 0; char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } for (a = 1; a < objc; a++) { const char *arg = Tcl_GetString(objv[a]); if (arg[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", NULL); return TCL_ERROR; } async = 1; break; case SKT_MYADDR: a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myaddr option", NULL); return TCL_ERROR; } myaddr = TclGetString(objv[a]); break; case SKT_MYPORT: { char *myPortName; a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myport option", NULL); return TCL_ERROR; } myPortName = TclGetString(objv[a]); if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { return TCL_ERROR; } break; } case SKT_SERVER: if (async == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", NULL); return TCL_ERROR; } server = 1; a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -server option", NULL); return TCL_ERROR; } script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { Tcl_AppendResult(interp, "option -myport is not valid for servers", NULL); return TCL_ERROR; } } else if (a < objc) { host = TclGetString(objv[a]); a++; } else { Interp *iPtr; wrongNumArgs: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "-server command ?-myaddr addr? port"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } if (a == objc-1) { if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", &port) != TCL_OK) { return TCL_ERROR; } } else { goto wrongNumArgs; } if (server) { AcceptCallback *acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) sizeof(AcceptCallback)); unsigned len = strlen(script) + 1; char *copyScript = ckalloc(len); memcpy(copyScript, script, len); acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { ckfree(copyScript); ckfree((char *) acceptCallbackPtr); return TCL_ERROR; } /* * Register with the interpreter to let us know when the interpreter * is deleted (by having the callback set the interp field of the * acceptCallbackPtr's structure to NULL). This is to avoid trying to * eval the script in a deleted interpreter. */ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); /* * Register a close callback. This callback will inform the * interpreter (if it still exists) that this channel does not need to * be informed when the interpreter is deleted. */ Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; }
static void AcceptCallbackProc( ClientData callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted * connection. */ char *address, /* Address of client that was accepted. */ int port) /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; /* * Check if the callback is still valid; the interpreter may have gone * away, this is signalled by setting the interp field of the callback * data to NULL. */ if (acceptCallbackPtr->interp != NULL) { char portBuf[TCL_INTEGER_SPACE]; char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; int result; Tcl_Preserve(script); Tcl_Preserve(interp); TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* * Artificially bump the refcount to protect the channel from being * deleted while the script is being evaluated. */ Tcl_RegisterChannel(NULL, chan); result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, NULL); if (result != TCL_OK) { TclBackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } /* * Decrement the artificially bumped refcount. After this it is not * safe anymore to use "chan", because it may now be deleted. */ Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to * utilize the client socket - just close it. */ Tcl_Close(NULL, chan); } }
/* ARGSUSED */ int Tcl_OpenObjCmd( ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int pipeline, prot; const char *modeString, *what; Tcl_Channel chan; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); return TCL_ERROR; } prot = 0666; if (objc == 2) { modeString = "r"; } else { modeString = TclGetString(objv[2]); if (objc == 4) { char *permString = TclGetString(objv[3]); int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); /* Support legacy octal numbers */ if ((permString[scanned] == '0') && (permString[scanned+1] >= '0') && (permString[scanned+1] <= '7')) { Tcl_Obj *permObj; TclNewLiteralStringObj(permObj, "0o"); Tcl_AppendToObj(permObj, permString+scanned+1, -1); code = TclGetIntFromObj(NULL, permObj, &prot); Tcl_DecrRefCount(permObj); } if ((code == TCL_ERROR) && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } pipeline = 0; what = TclGetString(objv[1]); if (what[0] == '|') { pipeline = 1; } /* * Open the file or create a process pipeline. */ if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, cmdObjc, binary; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { chan = NULL; } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: flags |= TCL_STDOUT; break; case O_WRONLY: flags |= TCL_STDIN; break; case O_RDWR: flags |= (TCL_STDIN | TCL_STDOUT); break; default: Tcl_Panic("Tcl_OpenCmd: invalid mode value"); break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary && chan) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } ckfree((char *) cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; }
int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_Channel tempChan; if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, (Tcl_PackageInitProc *) NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #endif /* TCL_TEST */ /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. * Each call would loo like this: * * Tcl_CreateCommand(interp, "tclName", CFuncCmd, NULL, NULL); */ /* * Specify a user-specific startup script to invoke if the application * is run interactively. On the Mac we can specifiy either a TEXT resource * which contains the script or the more UNIX like file location * may also used. (I highly recommend using the resource method.) */ Tcl_SetVar(interp, "tcl_rcRsrcName", "tclshrc", TCL_GLOBAL_ONLY); /* Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); */ /* * We have to support at least the quit Apple Event. */ TkMacInitAppleEvents(interp); /* * Open a file channel to put stderr, stdin, stdout... */ tempChan = Tcl_OpenFileChannel(interp, ":temp.in", "a+", 0); Tcl_SetStdChannel(tempChan,TCL_STDIN); Tcl_RegisterChannel(interp, tempChan); Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr"); Tcl_SetChannelOption(NULL, tempChan, "-buffering", "line"); tempChan = Tcl_OpenFileChannel(interp, ":temp.out", "a+", 0); Tcl_SetStdChannel(tempChan,TCL_STDOUT); Tcl_RegisterChannel(interp, tempChan); Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr"); Tcl_SetChannelOption(NULL, tempChan, "-buffering", "line"); tempChan = Tcl_OpenFileChannel(interp, ":temp.err", "a+", 0); Tcl_SetStdChannel(tempChan,TCL_STDERR); Tcl_RegisterChannel(interp, tempChan); Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr"); Tcl_SetChannelOption(NULL, tempChan, "-buffering", "none"); return TCL_OK; }
TclTextInterp::TclTextInterp(VMDApp *vmdapp, int guienabled, int mpienabled) : app(vmdapp) { interp = Tcl_CreateInterp(); #if 0 Tcl_InitMemory(interp); // enable Tcl memory debugging features // when compiled with TCL_MEM_DEBUG #endif commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); consoleisatty = vmd_isatty(0); // whether we're interactive or not ignorestdin = 0; gotPartial = 0; needPrompt = 1; callLevel = 0; starttime = delay = 0; #if defined(VMDMPI) // // 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. // // don't check for interactive console input if running in parallel if (mpienabled) ignorestdin = 1; #endif #if defined(ANDROIDARMV7A) // // 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. // // Don't check for interactive console input if compiled for Android ignorestdin = 1; #endif // set tcl_interactive, lets us run unix commands as from a shell #if !defined(VMD_NANOHUB) Tcl_SetVar(interp, "tcl_interactive", "1", 0); #else Tcl_SetVar(interp, "tcl_interactive", "0", 0); Tcl_Channel channel; #define CLIENT_READ (3) #define CLIENT_WRITE (4) channel = Tcl_MakeFileChannel((ClientData)CLIENT_READ, TCL_READABLE); if (channel != NULL) { const char *result; Tcl_RegisterChannel(interp, channel); result = Tcl_SetVar2(interp, "vmd_client", "read", Tcl_GetChannelName(channel), TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); if (result == NULL) { fprintf(stderr, "can't create variable for client read channel\n"); } } channel = Tcl_MakeFileChannel((ClientData)CLIENT_WRITE, TCL_WRITABLE); if (channel != NULL) { const char *result; Tcl_RegisterChannel(interp, channel); result = Tcl_SetVar2(interp, "vmd_client", "write", Tcl_GetChannelName(channel), TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); if (result == NULL) { fprintf(stderr, "can't create variable for client write channel\n"); } } write(CLIENT_WRITE, "vmd 1.0\n", 8); #endif // pass our instance of VMDApp to a hash table assoc. with the interpreter Tcl_SetAssocData(interp, "VMDApp", NULL, app); // Set up argc, argv0, and argv variables { char argcbuf[20]; sprintf(argcbuf, "%d", app->argc_m); Tcl_SetVar(interp, "argc", argcbuf, TCL_GLOBAL_ONLY); // it might be better to use the same thing that was passed to // Tcl_FindExecutable, but this is now Tcl_SetVar(interp, "argv0", app->argv_m[0], TCL_GLOBAL_ONLY); char *args = Tcl_Merge(app->argc_m-1, app->argv_m+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); Tcl_Free(args); } #if defined(_MSC_VER) && TCL_MINOR_VERSION >= 4 // The Windows versions of Tcl 8.5.x have trouble finding // the Tcl library subdirectory for unknown reasons. // We force the appropriate env variables to be set in Tcl, // despite Windows. { char vmdinitscript[4096]; char * tcl_library = getenv("TCL_LIBRARY"); char * tk_library = getenv("TK_LIBRARY"); if (tcl_library) { sprintf(vmdinitscript, "set env(TCL_LIBRARY) {%s}", tcl_library); if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) { msgErr << Tcl_GetStringResult(interp) << sendmsg; } } if (tk_library) { sprintf(vmdinitscript, "set env(TK_LIBRARY) {%s}", tk_library); if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) { msgErr << Tcl_GetStringResult(interp) << sendmsg; } } } #endif if (Tcl_Init(interp) == TCL_ERROR) { // new with 7.6 msgErr << "Tcl startup error: " << Tcl_GetStringResult(interp) << sendmsg; } #ifdef VMDTK // and the Tk commands (but only if a GUI is available!) if (guienabled) { if (Tk_Init(interp) == TCL_ERROR) { msgErr << "Tk startup error: " << Tcl_GetStringResult(interp) << sendmsg; } else { Tcl_StaticPackage(interp, "Tk", (Tcl_PackageInitProc *) Tk_Init, (Tcl_PackageInitProc *) NULL); } } // end of check that GUI is allowed #endif add_commands(); }
int TclFileTemporaryCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary * file in. */ Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ Tcl_Channel chan; /* The channel opened (RDWR) on the temporary * file, or NULL if there's an error. */ Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; /* Pieces of template. Each piece is NULL if * it is omitted. The platform temporary file * engine might ignore some pieces. */ if (objc < 1 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?"); return TCL_ERROR; } if (objc > 1) { nameVarObj = objv[1]; TclNewObj(nameObj); } if (objc > 2) { int length; Tcl_Obj *templateObj = objv[2]; const char *string = TclGetStringFromObj(templateObj, &length); /* * Treat an empty string as if it wasn't there. */ if (length == 0) { goto makeTemporary; } /* * The template only gives a directory if there is a directory * separator in it. */ if (strchr(string, '/') != NULL || (tclPlatform == TCL_PLATFORM_WINDOWS && strchr(string, '\\') != NULL)) { tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); /* * Only allow creation of temporary files in the native filesystem * since they are frequently used for integration with external * tools or system libraries. [Bug 2388866] */ if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) != &tclNativeFilesystem) { TclDecrRefCount(tempDirObj); tempDirObj = NULL; } } /* * The template only gives the filename if the last character isn't a * directory separator. */ if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS || string[length-1] != '\\')) { Tcl_Obj *tailObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); if (tailObj != NULL) { tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); TclDecrRefCount(tailObj); } } } /* * Convert empty parts of the template into unspecified parts. */ if (tempDirObj && !TclGetString(tempDirObj)[0]) { TclDecrRefCount(tempDirObj); tempDirObj = NULL; } if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { TclDecrRefCount(tempBaseObj); tempBaseObj = NULL; } if (tempExtObj && !TclGetString(tempExtObj)[0]) { TclDecrRefCount(tempExtObj); tempExtObj = NULL; } /* * Create and open the temporary file. */ makeTemporary: chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); /* * If we created pieces of template, get rid of them now. */ if (tempDirObj) { TclDecrRefCount(tempDirObj); } if (tempBaseObj) { TclDecrRefCount(tempBaseObj); } if (tempExtObj) { TclDecrRefCount(tempExtObj); } /* * Deal with results. */ if (chan == NULL) { if (nameVarObj) { TclDecrRefCount(nameObj); } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create temporary file: %s", Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); if (nameVarObj != NULL) { if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_UnregisterChannel(interp, chan); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; }
/*----------------------------------------------------------------------------- * TclX_ServerCreateCmd -- * Implements the TCL server_create command: * * server_create ?options? * * Creates a socket, binds the address and port on the local machine * (optionally specified by the caller), and starts the port listening * for connections by calling listen (2). * * Options may be "-myip ip_address", "-myport port_number", * "-myport reserved", and "-backlog backlog". * * Results: * If successful, a Tcl fileid is returned. * *----------------------------------------------------------------------------- */ static int TclX_ServerCreateCmd (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv) { int socketFD = -1, nextArg; struct sockaddr_in local; int myPort, value; int backlog = 5; int getReserved = FALSE; Tcl_Channel channel = NULL; /* * Parse arguments. */ bzero ((VOID *) &local, sizeof (local)); local.sin_family = AF_INET; local.sin_addr.s_addr = INADDR_ANY; nextArg = 1; while ((nextArg < argc) && (argv [nextArg][0] == '-')) { if (STREQU ("-myip", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (TclXOSInetAtoN (interp, argv [nextArg], &local.sin_addr) == TCL_ERROR) return TCL_ERROR; } else if (STREQU ("-myport", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (STREQU (argv [nextArg], "reserved")) { getReserved = TRUE; } else { if (Tcl_GetInt (interp, argv [nextArg], &myPort) != TCL_OK) return TCL_ERROR; local.sin_port = htons (myPort); } } else if (STREQU ("-backlog", argv [nextArg])) { if (nextArg >= argc - 1) goto missingArg; nextArg++; if (Tcl_GetInt (interp, argv [nextArg], &backlog) != TCL_OK) return TCL_ERROR; } else if (STREQU ("-reuseaddr", argv [nextArg])) { /* Ignore for compatibility */ } else { TclX_AppendObjResult (interp, "expected ", "\"-myip\", \"-myport\", or \"-backlog\", ", "got \"", argv [nextArg], "\"", (char *) NULL); return TCL_ERROR; } nextArg++; } if (nextArg != argc) { TclX_AppendObjResult (interp, tclXWrongArgs, argv[0], " ?options?", (char *) NULL); return TCL_ERROR; } /* * Allocate a reserved port if requested. */ if (getReserved) { int port; if (rresvport (&port) < 0) goto unixError; local.sin_port = port; } /* * Open a socket and bind an address and port to it. */ socketFD = socket (local.sin_family, SOCK_STREAM, 0); if (socketFD < 0) goto unixError; value = 1; if (setsockopt (socketFD, SOL_SOCKET, SO_REUSEADDR, (void*) &value, sizeof (value)) < 0) { goto unixError; } if (bind (socketFD, (struct sockaddr *) &local, sizeof (local)) < 0) { goto unixError; } if (listen (socketFD, backlog) < 0) goto unixError; channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD); Tcl_RegisterChannel (interp, channel); TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), (char *) NULL); return TCL_OK; /* * Exit points for errors. */ missingArg: TclX_AppendObjResult (interp, "missing argument for ", argv [nextArg], (char *) NULL); return TCL_ERROR; unixError: TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); CloseForError (interp, channel, socketFD); return TCL_ERROR; }
void Tk_InitConsoleChannels( Tcl_Interp *interp) { static Tcl_ThreadDataKey consoleInitKey; int *consoleInitPtr, doIn, doOut, doErr; ConsoleInfo *info; Tcl_Channel consoleChannel; /* * 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) { return; } consoleInitPtr = Tcl_GetThreadData(&consoleInitKey, (int) sizeof(int)); if (*consoleInitPtr) { /* * We've already initialized console channels in this thread. */ return; } *consoleInitPtr = 1; doIn = ShouldUseConsoleChannel(TCL_STDIN); doOut = ShouldUseConsoleChannel(TCL_STDOUT); doErr = ShouldUseConsoleChannel(TCL_STDERR); if (!(doIn || doOut || doErr)) { /* * No std channels should be tied to the console; thus, no need to * create the console. */ return; } /* * At least one std channel wants to be tied to the console, so create the * interp for it to live in. */ info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo)); info->consoleInterp = NULL; info->interp = NULL; info->refCount = 0; if (doIn) { ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData)); data->info = info; data->info->refCount++; data->type = TCL_STDIN; consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0", data, TCL_READABLE); if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDIN); Tcl_RegisterChannel(NULL, consoleChannel); } if (doOut) { ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData)); data->info = info; data->info->refCount++; data->type = TCL_STDOUT; consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1", data, TCL_WRITABLE); if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDOUT); Tcl_RegisterChannel(NULL, consoleChannel); } if (doErr) { ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData)); data->info = info; data->info->refCount++; data->type = TCL_STDERR; consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2", data, TCL_WRITABLE); if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDERR); Tcl_RegisterChannel(NULL, consoleChannel); } }
/* * Create and register a new channel for the connection */ int PgSetConnectionId(Tcl_Interp *interp, PGconn *conn, char *chandle) { Tcl_Channel conn_chan; Tcl_Obj *nsstr; Pg_ConnectionId *connid; int i; CONST char *ns = ""; connid = (Pg_ConnectionId *) ckalloc(sizeof(Pg_ConnectionId)); connid->conn = conn; connid->res_count = 0; connid->res_last = -1; connid->res_max = RES_START; connid->res_hardmax = RES_HARD_MAX; connid->res_copy = -1; connid->res_copyStatus = RES_COPY_NONE; connid->results = (PGresult **)ckalloc(sizeof(PGresult *) * RES_START); connid->resultids = (Pg_resultid **)ckalloc(sizeof(Pg_resultid *) * RES_START); for (i = 0; i < RES_START; i++) { connid->results[i] = NULL; connid->resultids[i] = NULL; } connid->notify_list = NULL; connid->notifier_running = 0; connid->interp = interp; connid->nullValueString = NULL; nsstr = Tcl_NewStringObj("if {[namespace current] != \"::\"} {set k [namespace current]::}", -1); Tcl_EvalObjEx(interp, nsstr, 0); /* Tcl_Eval(interp, "if {[namespace current] != \"::\"} {\ set k [namespace current]::\ }"); */ ns = Tcl_GetStringResult(interp); Tcl_ResetResult(interp); if (chandle == NULL) { sprintf(connid->id, "%spgsql%d", ns, PQsocket(conn)); } else { sprintf(connid->id, "%s%s", ns, chandle); } conn_chan = Tcl_GetChannel(interp, connid->id, 0); if (conn_chan != NULL) { return 0; } connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData)(long)PQsocket(conn)); /* Code executing outside of any Tcl interpreter can call Tcl_RegisterChannel with interp as NULL, to indicate that it wishes to hold a reference to this channel. Subse- quently, the channel can be registered in a Tcl inter- preter and it will only be closed when the matching number of calls to Tcl_UnregisterChannel have been made. This allows code executing outside of any interpreter to safely hold a reference to a channel that is also registered in a Tcl interpreter. */ Tcl_RegisterChannel(NULL, connid->notifier_channel); conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid, TCL_READABLE | TCL_WRITABLE); Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line"); Tcl_SetResult(interp, connid->id, TCL_VOLATILE); Tcl_RegisterChannel(interp, conn_chan); connid->cmd_token=Tcl_CreateObjCommand(interp, connid->id, PgConnCmd, (ClientData) connid, PgDelCmdHandle); return 1; }