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