summaryrefslogtreecommitdiffstats
path: root/generic/tclIOCmd.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIOCmd.c')
-rw-r--r--generic/tclIOCmd.c220
1 files changed, 161 insertions, 59 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 2958bc8..13a6853 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -7,6 +7,8 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.64 2009/04/27 09:41:49 nijtmans Exp $
*/
#include "tclInt.h"
@@ -133,24 +135,32 @@ Tcl_PutsObjCmd(
break;
case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
- newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
chanObjPtr = objv[2];
string = objv[3];
- break;
- } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
+ } else {
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
- * documented. See also [Bug #3151675]. Will be removed in Tcl 9,
- * maybe even earlier.
+ * documented.
*/
+ const char *arg;
+ int length;
+
+ arg = TclGetStringFromObj(objv[3], &length);
+ if ((length != 9)
+ || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": should be \"nonewline\"", NULL);
+ return TCL_ERROR;
+ }
chanObjPtr = objv[1];
string = objv[2];
- break;
}
- /* Fall through */
+ newline = 0;
+ break;
+
default:
/* [puts] or [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
@@ -392,7 +402,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;
}
@@ -419,28 +428,24 @@ Tcl_ReadObjCmd(
i++; /* Consumed channel name. */
/*
- * Compute how many bytes to read.
+ * Compute how many bytes to read, and see whether the final newline
+ * should be dropped.
*/
toRead = -1;
if (i < objc) {
- if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
- /*
- * The code below provides backwards compatibility with an old
- * form of the command that is no longer recommended or
- * documented. See also [Bug #3151675]. Will be removed in Tcl 9,
- * maybe even earlier.
- */
+ const char *arg;
- if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
- return TCL_ERROR;
+ 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 if (toRead < 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected non-negative integer but got \"",
- TclGetString(objv[i]), "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
+ } else {
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": should be \"nonewline\"", NULL);
return TCL_ERROR;
}
}
@@ -471,7 +476,7 @@ Tcl_ReadObjCmd(
*/
if ((charactersRead > 0) && (newline != 0)) {
- char *result;
+ const char *result;
int length;
result = TclGetStringFromObj(resultPtr, &length);
@@ -515,10 +520,10 @@ 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 CONST int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
+ static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
@@ -642,8 +647,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 +656,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 +713,7 @@ Tcl_CloseObjCmd(
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- char *string;
+ const char *string;
int len;
if (Tcl_IsShared(resultPtr)) {
@@ -706,13 +755,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 +880,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 +916,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;
}
@@ -1057,7 +1106,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);
@@ -1122,7 +1171,7 @@ Tcl_OpenObjCmd(
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
- if (binary && chan) {
+ if (binary) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
@@ -1328,7 +1377,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 +1461,14 @@ Tcl_SocketObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- static const char *socketOptions[] = {
+ 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 +1504,7 @@ Tcl_SocketObjCmd(
myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
- char *myPortName;
+ const char *myPortName;
a++;
if (a >= objc) {
@@ -1508,7 +1557,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;
}
@@ -1594,7 +1642,7 @@ Tcl_FcopyObjCmd(
Tcl_Channel inChan, outChan;
int mode, i, toRead, index;
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)) {
@@ -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,57 @@ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInitChanCmd --
*
* This function is invoked to create the "chan" Tcl command. See the
@@ -1823,22 +1922,25 @@ TclInitChanCmd(
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
- {"blocked", Tcl_FblockedObjCmd, NULL},
- {"close", Tcl_CloseObjCmd, NULL},
- {"copy", Tcl_FcopyObjCmd, NULL},
- {"create", TclChanCreateObjCmd, NULL}, /* TIP #219 */
- {"eof", Tcl_EofObjCmd, NULL},
- {"event", Tcl_FileEventObjCmd, NULL},
- {"flush", Tcl_FlushObjCmd, NULL},
- {"gets", Tcl_GetsObjCmd, NULL},
- {"pending", ChanPendingObjCmd, NULL}, /* TIP #287 */
- {"postevent", TclChanPostEventObjCmd, NULL}, /* TIP #219 */
- {"puts", Tcl_PutsObjCmd, NULL},
- {"read", Tcl_ReadObjCmd, NULL},
- {"seek", Tcl_SeekObjCmd, NULL},
- {"tell", Tcl_TellObjCmd, NULL},
- {"truncate", ChanTruncateObjCmd, NULL}, /* TIP #208 */
- {NULL,NULL, NULL}
+ {"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 */
+ {"pop", TclChanPopObjCmd}, /* TIP #230 */
+ {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */
+ {"push", TclChanPushObjCmd}, /* TIP #230 */
+ {"puts", Tcl_PutsObjCmd},
+ {"read", Tcl_ReadObjCmd},
+ {"seek", Tcl_SeekObjCmd},
+ {"pipe", ChanPipeObjCmd}, /* TIP #304 */
+ {"tell", Tcl_TellObjCmd},
+ {"truncate", ChanTruncateObjCmd}, /* TIP #208 */
+ {NULL}
};
static const char *const extras[] = {
"configure", "::fconfigure",
generated by cgit v0.12 at 2025-04-30 11:43:24 (GMT)