diff options
| -rw-r--r-- | generic/tclIO.c | 111 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 44 | ||||
| -rw-r--r-- | tests/io.test | 724 |
3 files changed, 504 insertions, 375 deletions
diff --git a/generic/tclIO.c b/generic/tclIO.c index 57c1554..af9a42d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -221,8 +221,8 @@ static void StopCopy(CopyState *csPtr); static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); -static int Write(Channel *chanPtr, const char *src, - int srcLen, Tcl_Encoding encoding); +static Tcl_Size Write(Channel *chanPtr, const char *src, + Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); @@ -395,7 +395,7 @@ ChanClose( * Results: * The return value of the driver inputProc, * - number of bytes stored at dst, ot - * - TCL_INDEX_NONE on error, with a Posix error code available to the caller by + * - -1 on error, with a Posix error code available to the caller by * calling Tcl_GetErrno(). * * Side effects: @@ -433,7 +433,7 @@ ChanRead( ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; if (WillRead(chanPtr) < 0) { - return TCL_INDEX_NONE; + return -1; } bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, @@ -1239,7 +1239,7 @@ Tcl_UnregisterChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", TCL_INDEX_NONE)); + " of channel", -1)); } return TCL_ERROR; } @@ -2727,7 +2727,7 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to access channel: invalid channel", TCL_INDEX_NONE)); + "unable to access channel: invalid channel", -1)); } return 1; } @@ -2925,7 +2925,7 @@ FlushChannel( if (interp != NULL && !TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); + Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } /* @@ -3500,7 +3500,7 @@ Tcl_Close( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", TCL_INDEX_NONE)); + " of channel", -1)); } return TCL_ERROR; } @@ -3613,7 +3613,7 @@ Tcl_Close( Tcl_SetErrno(stickyError); if (interp != NULL) { Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); + Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } return TCL_ERROR; } @@ -3631,7 +3631,7 @@ Tcl_Close( && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(result); Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); + Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } if (result != 0) { return TCL_ERROR; @@ -3703,7 +3703,7 @@ Tcl_CloseEx( if (chanPtr != statePtr->topChanPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "half-close not applicable to stack of transformations", TCL_INDEX_NONE)); + "half-close not applicable to stack of transformations", -1)); return TCL_ERROR; } @@ -3736,7 +3736,7 @@ Tcl_CloseEx( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", TCL_INDEX_NONE)); + " of channel", -1)); } return TCL_ERROR; } @@ -4337,7 +4337,7 @@ WillRead( DiscardInputQueued(chanPtr->state, 0); Tcl_SetErrno(EINVAL); - return TCL_INDEX_NONE; + return -1; } if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) #ifndef TCL_NO_DEPRECATED @@ -4355,7 +4355,7 @@ WillRead( */ if (FlushChannel(NULL, chanPtr, 0) != 0) { - return TCL_INDEX_NONE; + return -1; } } return 0; @@ -4382,11 +4382,11 @@ WillRead( *---------------------------------------------------------------------- */ -static int +static Tcl_Size Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - int srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */ Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; @@ -4405,7 +4405,6 @@ Write( */ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); - if (GotFlag(statePtr, CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { nextNewLine = (char *)memchr(src, '\n', srcLen); @@ -4414,7 +4413,8 @@ Write( while (srcLen + saved + endEncoding > 0 && !encodingError) { ChannelBuffer *bufPtr; char *dst; - int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; + int result, srcRead, dstLen, dstWrote; + Tcl_Size srcLimit = srcLen; if (nextNewLine) { srcLimit = nextNewLine - src; @@ -4538,7 +4538,7 @@ Write( if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { - return TCL_INDEX_NONE; + return -1; } flushed += statePtr->bufSize; @@ -4561,7 +4561,7 @@ Write( if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) || (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) { if (FlushChannel(NULL, chanPtr, 0) != 0) { - return TCL_INDEX_NONE; + return -1; } } @@ -4569,7 +4569,7 @@ Write( if (encodingError) { Tcl_SetErrno(EILSEQ); - return TCL_INDEX_NONE; + return -1; } return total; } @@ -4655,6 +4655,7 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { UpdateInterest(chanPtr); + ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR); Tcl_SetErrno(EILSEQ); return TCL_INDEX_NONE; } @@ -4919,11 +4920,11 @@ Tcl_GetsObj( && GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { /* Set eol to the position that caused the encoding error, and then - * coninue to gotEOL, which stores the data that was decoded + * continue to gotEOL, which stores the data that was decoded * without error to objPtr. This allows the caller to do something * useful with the data decoded so far, and also results in the * position of the file being the first byte that was not - * succesfully decoded, allowing further processing at exactly that + * successfully decoded, allowing further processing at exactly that * point, if desired. */ eol = dstEnd; @@ -5044,11 +5045,12 @@ Tcl_GetsObj( } UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); - if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && - (copiedTotal == 0 || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) { + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && gs.bytesWrote == 0) { + bufPtr->nextRemoved = oldRemoved; Tcl_SetErrno(EILSEQ); copiedTotal = -1; } + ResetFlag(statePtr, CHANNEL_ENCODING_ERROR); return copiedTotal; } @@ -5220,7 +5222,7 @@ TclGetsObjBinary( byteArray = Tcl_SetByteArrayLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); - copiedTotal = TCL_INDEX_NONE; + copiedTotal = -1; ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } @@ -5309,7 +5311,7 @@ TclGetsObjBinary( */ SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); - copiedTotal = TCL_INDEX_NONE; + copiedTotal = -1; /* * Update the notifier state so we don't block while there is still data @@ -5506,6 +5508,8 @@ FilterInputBytes( if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + ResetFlag(statePtr, CHANNEL_STICKY_EOF); + ResetFlag(statePtr, CHANNEL_EOF); result = TCL_OK; } @@ -5861,7 +5865,7 @@ Tcl_ReadRaw( */ if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { - copied = TCL_INDEX_NONE; + copied = -1; } } else if (nread > 0) { /* @@ -5973,14 +5977,15 @@ DoReadChars( /* State info for channel */ ChannelBuffer *bufPtr; Tcl_Size copied; - int result, copiedNow; + int result; Tcl_Encoding encoding = statePtr->encoding; int binaryMode; #define UTF_EXPANSION_FACTOR 1024 int factor = UTF_EXPANSION_FACTOR; if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { - /* TODO: We don't need this call? */ + ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR); + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); Tcl_SetErrno(EILSEQ); return -1; @@ -5997,7 +6002,7 @@ DoReadChars( assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6011,7 +6016,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6058,8 +6063,8 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - for (copied = 0; (unsigned) toRead > 0; ) { - copiedNow = TCL_INDEX_NONE; + for (copied = 0; toRead != 0 ; ) { + int copiedNow = -1; if (statePtr->inQueueHead != NULL) { if (binaryMode) { copiedNow = ReadBytes(statePtr, objPtr, toRead); @@ -6068,7 +6073,7 @@ DoReadChars( } /* - * If the current buffer is empty recycle it. + * Recycle current buffer if empty. */ bufPtr = statePtr->inQueueHead; @@ -6112,7 +6117,7 @@ DoReadChars( } if (result != 0) { if (!GotFlag(statePtr, CHANNEL_BLOCKED)) { - copied = TCL_INDEX_NONE; + copied = -1; } break; } @@ -6164,6 +6169,7 @@ finish: * succesfully red before the error. Return an error so that callers * like [read] can also return an error. */ + ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR); Tcl_SetErrno(EILSEQ); copied = -1; } @@ -6356,7 +6362,12 @@ ReadChars( flags, &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); - if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) { + if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX + || ( + code == TCL_CONVERT_MULTIBYTE + && GotFlag(statePtr, CHANNEL_EOF + )) + ) { SetFlag(statePtr, CHANNEL_ENCODING_ERROR); code = TCL_OK; } @@ -6408,7 +6419,7 @@ ReadChars( */ Tcl_SetObjLength(objPtr, numBytes); - return TCL_INDEX_NONE; + return -1; } { @@ -6583,7 +6594,7 @@ ReadChars( SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } Tcl_SetObjLength(objPtr, numBytes); - return TCL_INDEX_NONE; + return -1; } /* @@ -7648,7 +7659,7 @@ Tcl_InputBuffered( } /* - * Don't forget the bytes in the topmost pushback area. + * Remember the bytes in the topmost pushback area. */ for (bufPtr = statePtr->topChanPtr->inQueueHead; bufPtr != NULL; @@ -7867,10 +7878,10 @@ Tcl_BadChannelOption( Tcl_Obj *errObj; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, genericopt, TCL_INDEX_NONE); + Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { TclDStringAppendLiteral(&ds, " "); - Tcl_DStringAppend(&ds, optionList, TCL_INDEX_NONE); + Tcl_DStringAppend(&ds, optionList, -1); } if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { @@ -8183,7 +8194,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unable to set channel options: background copy in" - " progress", TCL_INDEX_NONE)); + " progress", -1)); } return TCL_ERROR; } @@ -8234,7 +8245,7 @@ Tcl_SetChannelOption( } else if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -buffering: must be one of" - " full, line, or none", TCL_INDEX_NONE)); + " full, line, or none", -1)); return TCL_ERROR; } return TCL_OK; @@ -8363,7 +8374,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", TCL_INDEX_NONE)); + " element list", -1)); } ckfree(argv); return TCL_ERROR; @@ -8393,7 +8404,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE)); + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -8443,7 +8454,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE)); + "auto, binary, cr, lf, crlf, or platform", -1)); } ckfree(argv); return TCL_ERROR; @@ -10205,7 +10216,7 @@ DoRead( UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); - return TCL_INDEX_NONE; + return -1; } assert(IsBufferFull(bufPtr)); @@ -10614,7 +10625,7 @@ Tcl_GetChannelNamesEx( && (pattern[2] == 'd'))) { if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL) && (Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(pattern, TCL_INDEX_NONE)) != TCL_OK)) { + Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { goto error; } goto done; @@ -10641,7 +10652,7 @@ Tcl_GetChannelNamesEx( if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(name, TCL_INDEX_NONE)) != TCL_OK)) { + Tcl_NewStringObj(name, -1)) != TCL_OK)) { error: TclDecrRefCount(resultPtr); return TCL_ERROR; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index bc4fab4..5a0a8da 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -106,7 +106,7 @@ Tcl_PutsObjCmd( Tcl_Obj *string; /* String to write. */ Tcl_Obj *chanObjPtr = NULL; /* channel object. */ int newline; /* Add a newline at end? */ - int result; /* Result of puts operation. */ + Tcl_Size result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ switch (objc) { @@ -176,12 +176,12 @@ Tcl_PutsObjCmd( TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); - if (result < 0) { + if (result == TCL_INDEX_NONE) { goto error; } if (newline != 0) { result = Tcl_WriteChars(chan, "\n", 1); - if (result < 0) { + if (result == TCL_INDEX_NONE) { goto error; } } @@ -293,7 +293,7 @@ Tcl_GetsObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ - int lineLen; /* Length of line just read. */ + Tcl_Size lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; int code = TCL_OK; @@ -316,7 +316,7 @@ Tcl_GetsObjCmd( TclChannelPreserve(chan); TclNewObj(linePtr); lineLen = Tcl_GetsObj(chan, linePtr); - if (lineLen < 0) { + if (lineLen == TCL_IO_FAILURE) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); @@ -335,7 +335,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - lineLen = TCL_INDEX_NONE; + lineLen = TCL_IO_FAILURE; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, @@ -343,7 +343,9 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen)); + Tcl_Obj *lineLenObj; + TclNewIndexObj(lineLenObj, lineLen); + Tcl_SetObjResult(interp, lineLenObj); } else { Tcl_SetObjResult(interp, linePtr); } @@ -379,7 +381,7 @@ Tcl_ReadObjCmd( 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? */ + Tcl_Size charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -429,9 +431,9 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) + if ((TclGetIntFromObj(NULL, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -446,7 +448,7 @@ Tcl_ReadObjCmd( TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) } newline = 1; #endif @@ -454,10 +456,10 @@ Tcl_ReadObjCmd( } TclNewObj(resultPtr); - Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); - if (charactersRead < 0) { + if (charactersRead == TCL_IO_FAILURE) { + Tcl_DecrRefCount(resultPtr); /* * TIP #219. * Capture error messages put by the driver into the bypass area and @@ -471,7 +473,6 @@ Tcl_ReadObjCmd( TclGetString(chanObjPtr), Tcl_PosixError(interp))); } TclChannelRelease(chan); - Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -481,7 +482,7 @@ Tcl_ReadObjCmd( if ((charactersRead > 0) && (newline != 0)) { const char *result; - int length; + Tcl_Size length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { @@ -490,7 +491,6 @@ Tcl_ReadObjCmd( } Tcl_SetObjResult(interp, resultPtr); TclChannelRelease(chan); - Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -724,7 +724,7 @@ Tcl_CloseObjCmd( Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; - int len; + Tcl_Size len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); @@ -884,7 +884,7 @@ Tcl_ExecObjCmd( const char *string; Tcl_Channel chan; int argc, background, i, index, keepNewline, result, skip, ignoreStderr; - int length; + Tcl_Size length; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; @@ -1145,7 +1145,7 @@ Tcl_OpenObjCmd( chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, binary; - int cmdObjc; + Tcl_Size cmdObjc; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { @@ -1313,7 +1313,7 @@ UnregisterTcpServerInterpCleanupProc( return; } - hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + hPtr = Tcl_FindHashEntry(hTblPtr, (char *)acceptCallbackPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1475,7 +1475,7 @@ Tcl_SocketObjCmd( SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + int a, server = 0, myport = 0, async = 0, reusep = -1, optionIndex, reusea = -1, backlog = -1; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; @@ -1814,9 +1814,9 @@ ChanPendingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - int index, mode; static const char *const options[] = {"input", "output", NULL}; enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; + int mode, index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); diff --git a/tests/io.test b/tests/io.test index 1efd69c..54ccaac 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1119,7 +1119,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + fconfigure $f -encoding shiftjis -profile tcl8 set x [list [gets $f line] $line [eof $f]] close $f set x @@ -1130,7 +1130,7 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + fconfigure $f -encoding shiftjis -profile tcl8 set x [list [gets $f line] $line] lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] lappend x [gets $f line] $line @@ -1474,67 +1474,67 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { } "{} timeout {} timeout 牦 {} eof 0 {}" test io-12.6 {ReadChars: too many chars read} { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat 뻯 20][string repeat . 20]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 15 + read $c 15 } close $c } {} test io-12.7 {ReadChars: too many chars read [bc5b790099]} { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat 뻯 10]....뻯] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat 뻯 10]....뻯] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 while {![eof $c]} { - read $c 7 + read $c 7 } close $c } {} @@ -1925,7 +1925,7 @@ test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(test1) set f [open $path(script) w] puts $f { - array set path [lindex $argv 0] + array set path [lindex $argv 0] set f [open $path(test1) w] puts $f hello close $f @@ -2272,7 +2272,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -2286,9 +2286,9 @@ test io-27.6 {FlushChannel, async flushing, async close} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result "file size only [file size $path(output)]" + set result "file size only [file size $path(output)]" } else { - set result ok + set result ok } } ok @@ -2347,7 +2347,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -2362,9 +2362,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ vwait [namespace which -variable counter] } if {$counter == 1000} { - set result probably_broken + set result probably_broken } else { - set result ok + set result ok } } ok test io-28.4 Tcl_Close testchannel { @@ -4552,29 +4552,29 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { } 300 test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4586,29 +4586,29 @@ test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -4620,30 +4620,30 @@ test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { } -result {{} {} {} .......} test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [string repeat \ - [string repeat . 64]\n[string repeat . 25] 2] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - if {$n > 65} {set n 65} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -5364,8 +5364,8 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} { } {0 abc 0 defghijklmnop 0 1} test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5400,8 +5400,8 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles } {0 abc 0 defghijklmnop 0 1} test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { proc in {f} { - variable l - variable x + variable l + variable x lappend l [read $f 3] if {[eof $f]} {lappend l eof; close $f; set x done} } @@ -5790,7 +5790,7 @@ test io-39.22a {Tcl_SetChannelOption, invariance} { set l } {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or - writable, it should still have valid -eofchar and -translation options } { + writable, it should still have valid -eofchar and -translation options } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] @@ -5798,7 +5798,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or set l } {{{}} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or - writable so we can't change -eofchar or -translation } { + writable so we can't change -eofchar or -translation } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] fconfigure $sock -eofchar D -translation lf @@ -6296,23 +6296,23 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent not test io-46.2 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - variable x 0 - after 100 {set x triggered} - vwait [namespace which -variable x] - set x + variable x 0 + after 100 {set x triggered} + vwait [namespace which -variable x] + set x } } {triggered} test io-46.3 {Tcl event loop vs multiple interpreters} testfevent { testfevent create testfevent cmd { - set x 0 - after 10 {lappend x timer} - after 30 - set result $x - update idletasks - lappend result $x - update - lappend result $x + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x } } {0 0 {0 timer}} @@ -6329,7 +6329,7 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} { lappend x [fileevent $f2 readable] testfevent delete lappend x [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] + [fileevent $f3 readable] close $f close $f2 close $f3 @@ -6345,11 +6345,11 @@ test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} { testfevent share $f2 testfevent share $f3 testfevent cmd "fileevent $f2 readable {script 2} - fileevent $f3 readable {script 3}" + fileevent $f3 readable {script 3}" fileevent $f4 readable {script 4} testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6370,7 +6370,7 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { fileevent $f4 readable {script 4}" testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6386,8 +6386,8 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent $f readable {script 2} fileevent $f2 readable {script 3} set x [list [fileevent $f2 readable] \ - [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] testfevent delete close $f close $f2 @@ -6401,7 +6401,7 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} testfevent cmd "fileevent $f readable {}" set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -6414,7 +6414,7 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} fileevent $f readable {} set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -7257,7 +7257,7 @@ test io-52.3 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7298,7 +7298,7 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7315,7 +7315,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7332,7 +7332,7 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7349,7 +7349,7 @@ test io-52.6 {TclCopyChannel} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7366,7 +7366,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { close $f1 close $f2 if {"$s1" == "$s2"} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7676,7 +7676,7 @@ test io-52.22 {TclCopyChannel & encodings} -setup { fconfigure $in -encoding ascii -profile strict fconfigure $out -encoding koi8-r -translation lf proc ::xxx args { - set ::s0 $args + set ::s0 $args } fcopy $in $out -command ::xxx @@ -7703,7 +7703,7 @@ test io-52.23 {TclCopyChannel & encodings} -setup { fconfigure $in -encoding utf-8 fconfigure $out -encoding ascii -translation lf -profile strict proc ::xxx args { - set ::s0 $args + set ::s0 $args } fcopy $in $out -command ::xxx @@ -7743,7 +7743,7 @@ test io-53.2 {CopyData} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -7861,6 +7861,8 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]] catch {unset fcopyTestDone} close $listen ;# This means the socket open never really succeeds + fconfigure $in -encoding utf-8 + fconfigure $out -encoding utf-8 fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if {![info exists fcopyTestDone]} { @@ -7898,8 +7900,8 @@ proc doFcopy {in out {bytes 0} {error {}}} { } elseif {[eof $in]} { set fcopyTestDone 0 } else { - # Delay next fcopy to wait for size>0 input bytes - after 100 [list fcopy $in $out -size 1000 \ + # Delay next fcopy to wait for size>0 input bytes + after 100 [list fcopy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } @@ -7914,9 +7916,9 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { proc Write {count} { puts -nonewline "1234567890" if {[incr count -1]} { - after 10 [list Write $count] + after 10 [list Write $count] } else { - set ::ready 1 + set ::ready 1 } } fconfigure stdout -buffering none @@ -8258,21 +8260,21 @@ test io-53.12.1 { } A test io-53.13 {TclCopyChannel: read error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch read} - } - finalize { - return - } - watch {} - read { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { error FAIL - } - } + } + } } set outFile [makeFile {} out] } -body { @@ -8285,24 +8287,24 @@ test io-53.13 {TclCopyChannel: read error reporting} -setup { catch {close $out} removeFile out rename driver {} -} -result {error reading "*": *} -returnCodes error -match glob +} -result {error reading "rc*": *} -returnCodes error -match glob test io-53.14 {TclCopyChannel: write error reporting} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - return {initialize finalize watch write} - } - finalize { - return - } - watch {} - write { - error FAIL - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } } set inFile [makeFile {aaa} in] } -body { @@ -8318,35 +8320,35 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup { } -result {error writing "*": *} -returnCodes error -match glob test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 @@ -8362,35 +8364,35 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { } -result 100 test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { proc driver {cmd args} { - variable buffer - variable index - variable blocked - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - set blocked($chan) 1 - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) blocked($chan) - return - } - watch {} - read { - if {$blocked($chan)} { - set blocked($chan) [expr {!$blocked($chan)}] - return -code error EAGAIN - } - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf @@ -8406,29 +8408,29 @@ test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { } -result 100 test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - line\n[string repeat a 100]line\n] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + line\n[string repeat a 100]line\n] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } set c [chan create read [namespace which driver]] chan configure $c -encoding utf-8 -translation lf -buffersize 107 @@ -9084,10 +9086,7 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} -# The following tests 75.1 to 75.5 exercise strict or tolerant channel -# encoding. -# TCL 8.7 only offers tolerant channel encoding, what is tested here. -test io-75.1 {multibyte encoding error read results in raw bytes} -setup { +test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary @@ -9178,23 +9177,27 @@ test io-75.5 {invalid utf-8 encoding read is ignored (-profile tcl8)} -setup { removeFile io-75.5 } -result 4181 -test io-75.6 {invalid utf-8 encoding gets is not ignored (-profile strict)} -setup { +test io-75.6 {invalid utf-8 encoding, gets is not ignored (-profile strict)} -setup { set fn [makeFile {} io-75.6] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 is invalid in utf-8 + # \x81 is an incomplete byte sequence in utf-8 puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile strict + fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ + -translation lf -profile strict } -body { gets $f } -cleanup { close $f removeFile io-75.6 -} -match glob -returnCodes 1 -result {error reading "*": invalid or incomplete multibyte or wide character} +} -match glob -returnCodes 1 -result {error reading "file*":\ + invalid or incomplete multibyte or wide character} -test io-75.7 {invalid utf-8 encoding gets is not ignored (-profile strict)} -setup { +test io-75.7 { + invalid utf-8 encoding gets is not ignored (-profile strict) +} -setup { set fn [makeFile {} io-75.7] set f [open $fn w+] fconfigure $f -encoding binary @@ -9202,23 +9205,27 @@ test io-75.7 {invalid utf-8 encoding gets is not ignored (-profile strict)} -set puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile strict + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ + -profile strict } -body { - read $f + list [catch {read $f} msg] $msg } -cleanup { close $f removeFile io-75.7 -} -match glob -returnCodes 1 -result {error reading "*": invalid or incomplete multibyte or wide character} +} -match glob -result {1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes precedence. + # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes + # precedence. puts -nonewline $f A\x1A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -profile strict + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ + -translation lf -profile strict } -body { set d [read $f] binary scan $d H* hd @@ -9230,6 +9237,52 @@ test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup { removeFile io-75.8 } -result {41 1 {}} +test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -setup { + set fn [makeFile {} io-75.8] + set f [open $fn w+] + # This also configures the channel encoding profile as strict. + fconfigure $f -encoding binary + # \x81 is invalid in utf-8. -eofchar is not detected, because it comes later. + puts -nonewline $f A\x81\x81\x1A + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ + -translation lf -profile strict +} -body { + set res [list [catch {read $f} cres] [eof $f]] + chan configure $f -encoding iso8859-1 + lappend res [read $f 1] + chan configure $f -encoding utf-8 + catch {read $f 1} cres + lappend res $cres + close $f + set res +} -cleanup { + removeFile io-75.8 +} -match glob -result "1 0 \x81 {error reading \"*\":\ + invalid or incomplete multibyte or wide character}" + + +test io-strict-multibyte-eof { + incomplete utf-8 sequence immediately prior to eof character + + See issue 25cdcb7e8fb381fb +} -setup { + set res {} + set chan [file tempfile]; + fconfigure $chan -encoding binary + puts -nonewline $chan \x81\x1A + flush $chan + seek $chan 0 + chan configure $chan -encoding utf-8 -profile strict +} -body { + list [catch {read $chan 1} cres] $cres +} -cleanup { + close $chan + unset res +} -match glob -result {1 {error reading "*":\ + invalid or incomplete multibyte or wide character}} + test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { set fn [makeFile {} io-75.9] set f [open $fn w+] @@ -9242,7 +9295,8 @@ test io-75.9 {unrepresentable character write passes and is replaced by ?} -setu } -cleanup { close $f removeFile io-75.9 -} -match glob -result [list {A} {error writing "*": invalid or incomplete multibyte or wide character}] +} -match glob -result [list {A} {error writing "*":\ + invalid or incomplete multibyte or wide character}] # Incomplete sequence test. # This error may IMHO only be detected with the close. @@ -9277,16 +9331,17 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -blocking 0 -eofchar "" -translation lf -profile strict + fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \ + -profile strict } -body { set d [read $f] binary scan $d H* hd - lappend hd [catch {set d [read $f]} msg] - lappend hd $msg + lappend hd [catch {set d [read $f]} msg] $msg } -cleanup { close $f removeFile io-75.11 -} -match glob -result {41 1 {error reading "*": invalid or incomplete multibyte or wide character}} +} -match glob -result {41 1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} test io-75.12 {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.12] @@ -9295,7 +9350,7 @@ test io-75.12 {invalid utf-8 encoding read is ignored} -setup { puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf } -body { set d [read $f] binary scan $d H* hd @@ -9316,16 +9371,75 @@ test io-75.13 { puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -blocking 0 -eofchar "" -translation lf -profile strict + fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \ + -profile strict } -body { set d [read $f] binary scan $d H* hd - lappend hd [catch {read $f} msg] - lappend hd $msg + lappend hd [catch {read $f} msg] $msg } -cleanup { close $f removeFile io-75.13 -} -match glob -result {41 1 {error reading "*": invalid or incomplete multibyte or wide character}} +} -match glob -result {41 1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} + +test io-75.14 { + [gets] succesfully returns lines prior to error + + invalid utf-8 encoding [gets] continues in non-strict mode after error +} -setup { + set chan [file tempfile] + fconfigure $chan -encoding binary + # \xC0\n is an invalid utf-8 sequence + puts -nonewline $chan a\nb\nc\xC0\nd\n + flush $chan + seek $chan 0 + fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \ + -translation auto -profile strict +} -body { + lappend res [gets $chan] + lappend res [gets $chan] + lappend res [catch {gets $chan} cres] $cres + chan configure $chan -profile tcl8 + lappend res [gets $chan] + lappend res [gets $chan] + close $chan + return $res +} -match glob -result {a b 1 {error reading "*":\ + invalid or incomplete multibyte or wide character} cÀ d} + +test io-75.15 { + invalid utf-8 encoding strict + gets does not hang + gets succeeds for the first two lines +} -setup { + set res {} + set chan [file tempfile] + fconfigure $chan -encoding binary + # \xC0\x40 is an invalid utf-8 sequence + puts $chan hello\nAB\nCD\xC0\x40EF\nGHI + seek $chan 0 +} -body { + #Now try to read it with [gets] + fconfigure $chan -encoding utf-8 -profile strict + lappend res [gets $chan] + lappend res [gets $chan] + lappend res [catch {gets $chan} cres] $cres + lappend res [catch {gets $chan} cres] $cres + chan configure $chan -translation binary + set data [read $chan 4] + foreach char [split $data {}] { + scan $char %c ord + lappend res [format %x $ord] + } + fconfigure $chan -encoding utf-8 -profile strict -translation auto + lappend res [gets $chan] + lappend res [gets $chan] + return $res +} -cleanup { + close $chan +} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\ + 1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI} # ### ### ### ######### ######### ######### @@ -9380,7 +9494,8 @@ test io-76.4 {channel mode dropping} -setup { } -returnCodes error -cleanup { close $f removeFile dummy -} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} test io-76.5 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] @@ -9401,7 +9516,8 @@ test io-76.6 {channel mode dropping} -setup { } -returnCodes error -cleanup { close $f removeFile dummy -} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} test io-76.7 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] @@ -9434,7 +9550,8 @@ test io-76.9 {channel mode dropping} -setup { } -returnCodes error -cleanup { close $f removeFile dummy -} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} test io-76.10 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] @@ -9445,7 +9562,8 @@ test io-76.10 {channel mode dropping} -setup { } -returnCodes error -cleanup { close $f removeFile dummy -} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} +} -match glob -result {Tcl_RemoveChannelMode error:\ + Bad mode, would make channel inacessible. Channel: "*"} # cleanup foreach file [list fooBar longfile script script2 output test1 pipe my_script \ |