int TclGetCompletionCodeFromObj( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *value, int *codePtr) /* Argument objects. */ { static const char *const returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, codePtr) == TCL_OK) { return TCL_OK; } /* * Value is not a legal completion code. */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad completion code \"%s\": must be" " ok, error, return, break, continue, or an integer", TclGetString(value))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); } return TCL_ERROR; }
/* ARGSUSED */ int Tcl_ReadObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); /* * Do not append directly; that makes ensembles using this command as * a subcommand produce the wrong message. */ iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } if (i == objc) { goto argerror; } chanObjPtr = objv[i]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), "\" wasn't opened for reading", NULL); return TCL_ERROR; } i++; /* Consumed channel name. */ /* * Compute how many bytes to read, and see whether the final newline * should be dropped. */ toRead = -1; if (i < objc) { char *arg; arg = TclGetString(objv[i]); if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", NULL); return TCL_ERROR; } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ if ((charactersRead > 0) && (newline != 0)) { char *result; int length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); return TCL_OK; }
/* 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_FcopyObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel inChan, outChan; int mode, i, toRead, index; Tcl_Obj *cmdPtr; static const char* switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?"); return TCL_ERROR; } /* * Parse the channel arguments and verify that they are readable or * writable, as appropriate. */ if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), "\" wasn't opened for reading", NULL); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), "\" wasn't opened for writing", NULL); return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } if (toRead<0) { /* * Handle all negative sizes like -1, meaning 'copy all'. By * resetting toRead we avoid changes in the core copying * functions (which explicitly check for -1 and crash on any * other negative value). */ toRead = -1; } break; case FcopyCommand: cmdPtr = objv[i+1]; break; } } return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); }
static int ExecuteCallback( TransformChannelData *dataPtr, /* Transformation with the callback. */ Tcl_Interp *interp, /* Current interpreter, possibly NULL. */ unsigned char *op, /* Operation invoking the callback. */ unsigned char *buf, /* Buffer to give to the script. */ int bufLen, /* And its length. */ int transmit, /* Flag, determines whether the result of the * callback is sent to the underlying channel * or not. */ int preserve) /* Flag. If true the procedure will preserve * the result state of all accessed * interpreters. */ { Tcl_Obj *resObj; /* See below, switch (transmit). */ int resLen; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); Tcl_Interp *eval = dataPtr->interp; Tcl_Preserve(eval); /* * Step 1, create the complete command to execute. Do this by appending * operation and buffer to operate upon to a copy of the callback * definition. We *cannot* create a list containing 3 objects and then use * 'Tcl_EvalObjv', because the command may contain additional prefixed * arguments. Feather's curried commands would come in handy here. */ if (preserve == P_PRESERVE) { state = Tcl_SaveInterpState(eval, res); } Tcl_IncrRefCount(command); Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); /* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */ Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen)); /* * Step 2, execute the command at the global level of the interpreter used * to create the transformation. Destroy the command afterward. If an * error occured and the current interpreter is defined and not equal to * the interpreter for the callback, then copy the error message into * current interpreter. Don't copy if in preservation mode. */ res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(command); command = NULL; if ((res != TCL_OK) && (interp != NULL) && (eval != interp) && (preserve == P_NO_PRESERVE)) { Tcl_SetObjResult(interp, Tcl_GetObjResult(eval)); Tcl_Release(eval); return res; } /* * Step 3, transmit a possible conversion result to the underlying * channel, or ourselves. */ switch (transmit) { case TRANSMIT_DONT: /* nothing to do */ break; case TRANSMIT_DOWN: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; case TRANSMIT_NUM: /* * Interpret result as integer number. */ resObj = Tcl_GetObjResult(eval); TclGetIntFromObj(eval, resObj, &dataPtr->maxRead); break; } Tcl_ResetResult(eval); if (preserve == P_PRESERVE) { (void) Tcl_RestoreInterpState(eval, state); } Tcl_Release(eval); return res; }