From c283aca1bc0ec35ab9788282ca2fd2ebadd83c93 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 17 Jun 2025 05:26:38 +0000 Subject: Document Tcl_CloseEx. Proposed fix for [4f338b91c1]. --- doc/OpenFileChnl.3 | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index cff2210..2977846 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -9,7 +9,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_CloseEx, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include \fR @@ -48,6 +48,9 @@ int \fBTcl_Close\fR(\fIinterp, channel\fR) .sp int +\fBTcl_CloseEx\fR(\fIinterp, channel, closeFlags\fR) +.sp +int \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int @@ -158,6 +161,10 @@ channel. The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. +.AP int closeFlags in +If \fB0\fR, the channel is closed in both directions. If \fBTCL_CLOSE_READ\fR, +the channel is only closed for reading. If \fBTCL_CLOSE_WRITE\fR, the channel +is only closed for writing. These flags must not be combined. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. @@ -370,7 +377,7 @@ If so, it returns 1, otherwise 0. .PP No attempt is made to check whether the given channel or the standard channels are initialized or otherwise valid. -.SH TCL_CLOSE +.SH "TCL_CLOSE AND TCL_CLOSEEX" .PP \fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a currently open channel. The channel should not be registered in any @@ -384,16 +391,23 @@ immediately; output is flushed in the background and the channel will be closed once all of the buffered data has been output. In this case errors during flushing are not reported. .PP -If the channel was closed successfully, \fBTcl_Close\fR returns \fBTCL_OK\fR. -If an error occurs, \fBTcl_Close\fR returns \fBTCL_ERROR\fR and records a -POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +\fBTcl_CloseEx\fR allows for both full closing and half-closing of channels +depending on its \fBcloseFlags\fR parameter. See the description of the +parameter above. It is an error to attempt to close the channel for +a direction for which it is not open. The channel is destroyed only when +it has been closed for both reading and writing. Only socket and command +pipe channels support half-closing. +.PP +If the channel was closed successfully, \fBTcl_Close\fR and \fBTcl_CloseEx\fR +return \fBTCL_OK\fR. If an error occurs, they return \fBTCL_ERROR\fR and record +a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. If the channel is being closed synchronously and an error occurs during closing of the channel and \fIinterp\fR is not NULL, an error message is left in the interpreter's result. .PP -Note: it is not safe to call \fBTcl_Close\fR on a channel that has been -registered using \fBTcl_RegisterChannel\fR; see the documentation for -\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever +Note: it is not safe to call the channel closing functions on a channel +that has been registered using \fBTcl_RegisterChannel\fR; see the documentation +for \fBTcl_RegisterChannel\fR, above, for details. If the channel has ever been given as the \fBchan\fR argument in a call to \fBTcl_RegisterChannel\fR, you should instead use \fBTcl_UnregisterChannel\fR, which will internally call \fBTcl_Close\fR -- cgit v0.12 From fea176b546ca6e85dee5c88887a9e3de9321ac76 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 18 Jun 2025 18:12:18 +0000 Subject: Start on [e8b18d7b1f] fix. --- generic/tclCmdAH.c | 46 +++++++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 673b4f8..59a30d2 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -551,14 +551,14 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags, &ds, failVarObj ? &errorLocation : NULL); /* NOTE: ds must be freed beyond this point even on error */ + switch (result) { case TCL_OK: errorLocation = TCL_INDEX_NONE; break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); - return TCL_ERROR; + goto done; default: /* * One of the TCL_CONVERT_* errors. If we were not interested in the @@ -567,8 +567,8 @@ EncodingConvertfromObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } break; } @@ -582,8 +582,8 @@ EncodingConvertfromObjCmd( TclNewIndexObj(failIndex, errorLocation); if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } } /* @@ -592,12 +592,14 @@ EncodingConvertfromObjCmd( */ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds)); + result = TCL_OK; - /* We're done with the encoding */ - - Tcl_FreeEncoding(encoding); - return TCL_OK; - +done: + Tcl_DStringFree(&ds); + if (encoding) { + Tcl_FreeEncoding(encoding); + } + return result; } /* @@ -651,8 +653,7 @@ EncodingConverttoObjCmd( break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); - return TCL_ERROR; + goto done; default: /* * One of the TCL_CONVERT_* errors. If we were not interested in the @@ -661,8 +662,8 @@ EncodingConverttoObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } break; } @@ -676,20 +677,23 @@ EncodingConverttoObjCmd( TclNewIndexObj(failIndex, errorLocation); if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (unsigned char*) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - /* We're done with the encoding */ + result = TCL_OK; - Tcl_FreeEncoding(encoding); - return TCL_OK; +done: + Tcl_DStringFree(&ds); + if (encoding) { + Tcl_FreeEncoding(encoding); + } + return result; } -- cgit v0.12 From 4b07d6b1e205c14627f49142057b272854872eab Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 20 Jun 2025 17:24:27 +0000 Subject: [ecf35c7120] Test for the bug. Open branch for fixing. --- tests/cmdMZ.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 7b9032a..3130ab6 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -193,6 +193,9 @@ test cmdMZ-return-2.18 {return option handling} { return -code error -errorstack [list CALL a CALL b] yo } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} +test cmdMZ-return-2.19 {return option handling} -body { + return -level 0 -code error -options {-options {-code break} -code continue} +} -returnCodes continue -result {} # Check that the result of a [return -options $opts $result] is # indistinguishable from that of the originally caught script, no matter what -- cgit v0.12 From 9631a6e07414f2d3aa2c4319db5edb75909e3f51 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Jun 2025 17:36:21 +0000 Subject: Two more tests demonstrating the inconsistency between processing -options {...} to emulate {*} argument expansion and processing according to the behavior of dictionaries and how [dict create] combines its arguments, notably how it handes duplicate keys. This is exposed by nested -options, because the outer processing handles in one way, while the nested processing handles in the other way. --- tests/cmdMZ.test | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 3130ab6..ff282b7 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -194,8 +194,18 @@ test cmdMZ-return-2.18 {return option handling} { } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} test cmdMZ-return-2.19 {return option handling} -body { - return -level 0 -code error -options {-options {-code break} -code continue} + return -level 0 -options {-options {-code break} -code continue} } -returnCodes continue -result {} +test cmdMZ-return-2.20 {return option handling} { + list [catch { + return -level 0 -options {-foo 1} -options {-bar 2} + } -> foo] $foo +} {0 {-foo 1 -bar 2 -code 0 -level 0}} +test cmdMZ-return-2.21 {return option handling} { + list [catch { + return -level 0 -options {-options {-foo 1} -options {-bar 2}} + } -> foo] $foo +} {0 {-foo 1 -bar 2 -code 0 -level 0}} # Check that the result of a [return -options $opts $result] is # indistinguishable from that of the originally caught script, no matter what -- cgit v0.12 From cc4e06ba607ab24a85339cb45e0b467014423372 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Jun 2025 19:58:15 +0000 Subject: [ecf35c7120] Pending fix for nested -options processing. --- generic/tclResult.c | 91 +++++++++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 41 deletions(-) diff --git a/generic/tclResult.c b/generic/tclResult.c index 2e7d378..1cf3910 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -793,6 +793,9 @@ TclProcessReturn( * * Parses, checks, and stores the options to the [return] command. * + * The number of arguments (objc) must be even, with the corresponding + * objv holding values to be processed as key value .... key value. + * * Results: * Returns TCL_ERROR if any of the option values are invalid. Otherwise, * returns TCL_OK, and writes the returnOpts, code, and level values to @@ -804,6 +807,49 @@ TclProcessReturn( *---------------------------------------------------------------------- */ +static int +ExpandedOptions( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj **keys, /* Built-in keys (per thread) */ + Tcl_Obj *returnOpts, /* Options dict we are building */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + for (; objc > 1; objv += 2, objc -= 2) { + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); + + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { + /* Process the -options switch to emulate {*} expansion. + * + * Use lists so duplicate keys are not lost. + */ + + Tcl_Size nestc; + Tcl_Obj **nestv; + + if (TCL_ERROR == TclListObjGetElements(interp, objv[1], + &nestc, &nestv) || (nestc % 2)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad -options value: expected dictionary but got" + " \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", + (char *)NULL); + return TCL_ERROR; + } + + if (TCL_ERROR == + ExpandedOptions(interp, keys, returnOpts, nestc, nestv)) { + return TCL_ERROR; + } + } else { + Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); + } + } + return TCL_OK; +} + int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ @@ -823,48 +869,11 @@ TclMergeReturnOptions( Tcl_Obj *returnOpts; Tcl_Obj **keys = GetKeys(); - TclNewObj(returnOpts); - for (; objc > 1; objv += 2, objc -= 2) { - const char *opt = TclGetString(objv[0]); - const char *compare = TclGetString(keys[KEY_OPTIONS]); - - if ((objv[0]->length == keys[KEY_OPTIONS]->length) - && (memcmp(opt, compare, objv[0]->length) == 0)) { - Tcl_DictSearch search; - int done = 0; - Tcl_Obj *keyPtr; - Tcl_Obj *dict = objv[1]; - - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, - &keyPtr, &valuePtr, &done)) { - /* - * Value is not a legal dictionary. - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad %s value: expected dictionary but got \"%s\"", - compare, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - (char *)NULL); - goto error; - } - - while (!done) { - Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); - } + /* All callers are expected to pass an even value for objc. */ - Tcl_DictObjGet(NULL, returnOpts, keys[KEY_OPTIONS], &valuePtr); - if (valuePtr != NULL) { - dict = valuePtr; - Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_OPTIONS]); - goto nestedOptions; - } - - } else { - Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); - } + TclNewObj(returnOpts); + if (TCL_ERROR == ExpandedOptions(interp, keys, returnOpts, objc, objv)) { + goto error; } /* -- cgit v0.12