diff options
Diffstat (limited to 'generic/tclIOCmd.c')
-rw-r--r-- | generic/tclIOCmd.c | 231 |
1 files changed, 183 insertions, 48 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e166e94..c889862 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -138,6 +138,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; +#if TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -149,6 +150,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[1]; string = objv[2]; break; +#endif } /* Fall through */ default: @@ -392,7 +394,6 @@ Tcl_ReadObjCmd( iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); - iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } @@ -424,7 +425,8 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -433,15 +435,16 @@ Tcl_ReadObjCmd( */ if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { - return TCL_ERROR; - } - newline = 1; - } else if (toRead < 0) { +#endif Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected non-negative integer but got \"", TclGetString(objv[i]), "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 + } + newline = 1; +#endif } } @@ -471,7 +474,7 @@ Tcl_ReadObjCmd( */ if ((charactersRead > 0) && (newline != 0)) { - char *result; + const char *result; int length; result = TclGetStringFromObj(resultPtr, &length); @@ -515,7 +518,7 @@ Tcl_SeekObjCmd( int mode; /* How to seek? */ Tcl_WideInt result; /* Of calling Tcl_Seek. */ int optionIndex; - static const char *originOptions[] = { + static const char *const originOptions[] = { "start", "current", "end", NULL }; static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; @@ -642,8 +645,8 @@ Tcl_CloseObjCmd( { Tcl_Channel chan; /* The channel to close. */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); return TCL_ERROR; } @@ -651,6 +654,50 @@ Tcl_CloseObjCmd( return TCL_ERROR; } + if (objc == 3) { + int optionIndex, dir; + static const char *const dirOptions[] = { + "read", "write", NULL + }; + static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; + + /* + * Get direction requested to close, and check syntax. + */ + + if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + dir = dirArray[optionIndex]; + + /* + * Check direction against channel mode. It is an error if we try to + * close a direction not supported by the channel (already closed, or + * never opened for that direction). + */ + + if (!(dir & Tcl_GetChannelMode(chan))) { + Tcl_AppendResult(interp, "Half-close of ", + dirOptions[optionIndex], + "-side not possible, side not opened or already closed", + NULL); + return TCL_ERROR; + } + + /* + * Special handling is needed if and only if the channel mode supports + * more than the direction to close. Because if the close the last + * direction suppported we can and will go through the regular + * process. + */ + + if ((Tcl_GetChannelMode(chan) & + (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { + return Tcl_CloseEx(interp, chan, dir); + } + } + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { /* * If there is an error message and it ends with a newline, remove the @@ -664,7 +711,7 @@ Tcl_CloseObjCmd( */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - char *string; + const char *string; int len; if (Tcl_IsShared(resultPtr)) { @@ -706,13 +753,13 @@ Tcl_FconfigureObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - char *optionName, *valueName; + const char *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, - "channelId ?optionName? ?value? ?optionName value?..."); + "channelId ?-option value ...?"); return TCL_ERROR; } @@ -831,11 +878,11 @@ Tcl_ExecObjCmd( Tcl_Obj *resultPtr; const char **argv; - char *string; + const char *string; Tcl_Channel chan; int argc, background, i, index, keepNewline, result, skip, length; int ignoreStderr; - static const char *options[] = { + static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; enum options { @@ -867,7 +914,7 @@ Tcl_ExecObjCmd( } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? arg ?arg ...?"); return TCL_ERROR; } @@ -907,7 +954,7 @@ Tcl_ExecObjCmd( * Free the argv array. */ - TclStackFree(interp, (void *)argv); + TclStackFree(interp, (void *) argv); if (chan == NULL) { return TCL_ERROR; @@ -1057,7 +1104,7 @@ Tcl_OpenObjCmd( } else { modeString = TclGetString(objv[2]); if (objc == 4) { - char *permString = TclGetString(objv[3]); + const char *permString = TclGetString(objv[3]); int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); @@ -1222,7 +1269,7 @@ RegisterTcpServerInterpCleanup( TcpAcceptCallbacksDeleteProc, hTblPtr); } - hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew); + hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew); if (!isNew) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } @@ -1328,7 +1375,7 @@ AcceptCallbackProc( result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, NULL); if (result != TCL_OK) { - TclBackgroundException(interp, result); + Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } @@ -1412,14 +1459,14 @@ Tcl_SocketObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *socketOptions[] = { - "-async", "-myaddr", "-myport","-server", NULL + static const char *const 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; + const char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1455,7 +1502,7 @@ Tcl_SocketObjCmd( myaddr = TclGetString(objv[a]); break; case SKT_MYPORT: { - char *myPortName; + const char *myPortName; a++; if (a >= objc) { @@ -1508,7 +1555,6 @@ Tcl_SocketObjCmd( 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; } @@ -1592,9 +1638,10 @@ Tcl_FcopyObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel inChan, outChan; - int mode, i, toRead, index; + int mode, i, index; + Tcl_WideInt toRead; Tcl_Obj *cmdPtr; - static const char* switches[] = { "-size", "-command", NULL }; + static const char *const switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { @@ -1634,16 +1681,17 @@ Tcl_FcopyObjCmd( } switch (index) { case FcopySize: - if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } - if (toRead<0) { + 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; @@ -1685,7 +1733,7 @@ ChanPendingObjCmd( { Tcl_Channel chan; int index, mode; - static const char *options[] = {"input", "output", NULL}; + static const char *const options[] = {"input", "output", NULL}; enum options {PENDING_INPUT, PENDING_OUTPUT}; if (objc != 3) { @@ -1797,6 +1845,90 @@ ChanTruncateObjCmd( /* *---------------------------------------------------------------------- * + * ChanPipeObjCmd -- + * + * This function is invoked to process the "chan pipe" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a pair of Tcl channels wrapping both ends of a new + * anonymous pipe. + * + *---------------------------------------------------------------------- + */ + +static int +ChanPipeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel rchan, wchan; + const char *channelNames[2]; + Tcl_Obj *resultPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) { + return TCL_ERROR; + } + + channelNames[0] = Tcl_GetChannelName(rchan); + channelNames[1] = Tcl_GetChannelName(wchan); + + resultPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(channelNames[0], -1)); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(channelNames[1], -1)); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclChannelNamesCmd -- + * + * This function is invoked to process the "chan names" and "file + * channels" Tcl commands. See the user documentation for details on + * what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChannelNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 1) ? NULL : TclGetString(objv[1]))); +} + +/* + *---------------------------------------------------------------------- + * * TclInitChanCmd -- * * This function is invoked to create the "chan" Tcl command. See the @@ -1823,26 +1955,29 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd}, - {"close", Tcl_CloseObjCmd}, - {"copy", Tcl_FcopyObjCmd}, - {"create", TclChanCreateObjCmd}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd}, - {"event", Tcl_FileEventObjCmd}, - {"flush", Tcl_FlushObjCmd}, - {"gets", Tcl_GetsObjCmd}, - {"pending", ChanPendingObjCmd}, /* TIP #287 */ - {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ - {"puts", Tcl_PutsObjCmd}, - {"read", Tcl_ReadObjCmd}, - {"seek", Tcl_SeekObjCmd}, - {"tell", Tcl_TellObjCmd}, - {"truncate", ChanTruncateObjCmd}, /* TIP #208 */ - {NULL} + {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */ + {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0}, + {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */ + {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, NULL, 0} }; - static const char *extras[] = { + static const char *const extras[] = { "configure", "::fconfigure", - "names", "::file channels", NULL }; Tcl_Command ensemble; |