summaryrefslogtreecommitdiffstats
path: root/generic/tclIOCmd.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIOCmd.c')
-rw-r--r--generic/tclIOCmd.c224
1 files changed, 125 insertions, 99 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 1f0e4a9..14910d7 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -140,7 +140,7 @@ Tcl_PutsObjCmd(
string = objv[3];
break;
#if TCL_MAJOR_VERSION < 9
- } else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) {
+ } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -174,12 +174,14 @@ Tcl_PutsObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for writing", NULL);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
@@ -190,6 +192,7 @@ Tcl_PutsObjCmd(
goto error;
}
}
+ Tcl_Release(chan);
return TCL_OK;
/*
@@ -201,9 +204,10 @@ Tcl_PutsObjCmd(
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error writing \"", TclGetString(chanObjPtr),
- "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
@@ -244,12 +248,14 @@ Tcl_FlushObjCmd(
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
- if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
- "\" wasn't opened for writing", NULL);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
if (Tcl_Flush(chan) != TCL_OK) {
/*
* TIP #219.
@@ -259,12 +265,14 @@ Tcl_FlushObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error flushing \"",
- TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error flushing \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
+ Tcl_Release(chan);
return TCL_OK;
}
@@ -297,6 +305,7 @@ Tcl_GetsObjCmd(
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
+ int code = TCL_OK;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
@@ -306,12 +315,14 @@ Tcl_GetsObjCmd(
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);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
@@ -326,12 +337,12 @@ Tcl_GetsObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"",
- TclGetString(chanObjPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
lineLen = -1;
}
@@ -344,7 +355,9 @@ Tcl_GetsObjCmd(
} else {
Tcl_SetObjResult(interp, linePtr);
}
- return TCL_OK;
+ done:
+ Tcl_Release(chan);
+ return code;
}
/*
@@ -411,9 +424,10 @@ Tcl_ReadObjCmd(
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);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(chanObjPtr)));
return TCL_ERROR;
}
i++; /* Consumed channel name. */
@@ -436,11 +450,11 @@ Tcl_ReadObjCmd(
if (strcmp(TclGetString(objv[i]), "nonewline") != 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;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected non-negative integer but got \"%s\"",
+ TclGetString(objv[i])));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
+ return TCL_ERROR;
#if TCL_MAJOR_VERSION < 9
}
newline = 1;
@@ -450,6 +464,7 @@ Tcl_ReadObjCmd(
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
+ Tcl_Preserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
@@ -460,11 +475,11 @@ Tcl_ReadObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading \"",
- TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading \"%s\": %s",
+ TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
@@ -483,6 +498,7 @@ Tcl_ReadObjCmd(
}
}
Tcl_SetObjResult(interp, resultPtr);
+ Tcl_Release(chan);
Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
@@ -521,7 +537,7 @@ Tcl_SeekObjCmd(
static const char *const originOptions[] = {
"start", "current", "end", NULL
};
- static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
+ static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
@@ -542,6 +558,7 @@ Tcl_SeekObjCmd(
mode = modeArray[optionIndex];
}
+ Tcl_Preserve(chan);
result = Tcl_Seek(chan, offset, mode);
if (result == Tcl_LongAsWide(-1)) {
/*
@@ -552,12 +569,14 @@ Tcl_SeekObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_AppendResult(interp, "error during seek on \"",
- TclGetString(objv[1]), "\": ", Tcl_PosixError(interp),
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error during seek on \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
}
+ Tcl_Release(chan);
return TCL_ERROR;
}
+ Tcl_Release(chan);
return TCL_OK;
}
@@ -588,6 +607,7 @@ Tcl_TellObjCmd(
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
+ int code;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
@@ -603,6 +623,7 @@ Tcl_TellObjCmd(
return TCL_ERROR;
}
+ Tcl_Preserve(chan);
newLoc = Tcl_Tell(chan);
/*
@@ -611,7 +632,10 @@ Tcl_TellObjCmd(
* them into the regular interpreter result.
*/
- if (TclChanCaughtErrorBypass(interp, chan)) {
+
+ code = TclChanCaughtErrorBypass(interp, chan);
+ Tcl_Release(chan);
+ if (code) {
return TCL_ERROR;
}
@@ -648,7 +672,7 @@ Tcl_CloseObjCmd(
static const char *const dirOptions[] = {
"read", "write", NULL
};
- static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
+ static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE};
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?");
@@ -679,9 +703,9 @@ Tcl_CloseObjCmd(
*/
if (!(dir & Tcl_GetChannelMode(chan))) {
- Tcl_AppendResult(interp, "Half-close of ", dirOptions[index],
- "-side not possible, side not opened or already closed",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Half-close of %s-side not possible, side not opened"
+ " or already closed", dirOptions[index]));
return TCL_ERROR;
}
@@ -977,9 +1001,9 @@ Tcl_ExecObjCmd(
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error reading output from command: ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error reading output from command: %s",
+ Tcl_PosixError(interp)));
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
@@ -1048,9 +1072,10 @@ Tcl_FblockedObjCmd(
if (TclGetChannelFromObj(interp, objv[1], &chan, &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);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(objv[1])));
return TCL_ERROR;
}
@@ -1174,7 +1199,7 @@ Tcl_OpenObjCmd(
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
@@ -1479,8 +1504,8 @@ Tcl_SocketObjCmd(
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
- Tcl_AppendResult(interp,
- "cannot set -async option for server sockets", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
async = 1;
@@ -1488,8 +1513,8 @@ Tcl_SocketObjCmd(
case SKT_MYADDR:
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -myaddr option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -myaddr option", -1));
return TCL_ERROR;
}
myaddr = TclGetString(objv[a]);
@@ -1499,8 +1524,8 @@ Tcl_SocketObjCmd(
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -myport option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -myport option", -1));
return TCL_ERROR;
}
myPortName = TclGetString(objv[a]);
@@ -1511,15 +1536,15 @@ Tcl_SocketObjCmd(
}
case SKT_SERVER:
if (async == 1) {
- Tcl_AppendResult(interp,
- "cannot set -async option for server sockets", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
- Tcl_AppendResult(interp,
- "no argument given for -server option", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -server option", -1));
return TCL_ERROR;
}
script = TclGetString(objv[a]);
@@ -1531,8 +1556,8 @@ Tcl_SocketObjCmd(
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
- Tcl_AppendResult(interp, "option -myport is not valid for servers",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "option -myport is not valid for servers", -1));
return TCL_ERROR;
}
} else if (a < objc) {
@@ -1599,9 +1624,9 @@ Tcl_SocketObjCmd(
return TCL_ERROR;
}
}
- Tcl_RegisterChannel(interp, chan);
- Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
+ Tcl_RegisterChannel(interp, chan);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
@@ -1651,17 +1676,19 @@ Tcl_FcopyObjCmd(
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);
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for reading",
+ TclGetString(objv[1])));
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);
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't opened for writing",
+ TclGetString(objv[2])));
return TCL_ERROR;
}
@@ -1745,14 +1772,14 @@ ChanPendingObjCmd(
switch ((enum options) index) {
case PENDING_INPUT:
- if ((mode & TCL_READABLE) == 0) {
+ if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
- if ((mode & TCL_WRITABLE) == 0) {
+ if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
@@ -1806,8 +1833,8 @@ ChanTruncateObjCmd(
return TCL_ERROR;
}
if (length < 0) {
- Tcl_AppendResult(interp,
- "cannot truncate to negative length of file", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot truncate to negative length of file", -1));
return TCL_ERROR;
}
} else {
@@ -1817,18 +1844,17 @@ ChanTruncateObjCmd(
length = Tcl_Tell(chan);
if (length == Tcl_WideAsLong(-1)) {
- Tcl_AppendResult(interp,
- "could not determine current location in \"",
- TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not determine current location in \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
if (Tcl_TruncateChannel(chan, length) != TCL_OK) {
- Tcl_AppendResult(interp, "error during truncate on \"",
- TclGetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error during truncate on \"%s\": %s",
+ TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
@@ -1948,25 +1974,25 @@ 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},
- {"names", TclChannelNamesCmd},
- {"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 */
+ {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
+ {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
+ {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
+ {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
+ {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char *const extras[] = {
generated by cgit v0.12 at 2025-10-24 22:36:05 (GMT)