From 5a0ecd4f019a6185b275f70eb21501d1ad8fb7a6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Sep 2024 21:45:53 +0000 Subject: Code de-duplication, move it to TclParseNumber() --- generic/tclObj.c | 23 ----------------------- generic/tclStrToD.c | 12 ++++++++---- tests/binary.test | 14 +++++++------- tests/get.test | 2 +- 4 files changed, 16 insertions(+), 35 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 8cf0370..ea900a2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2081,11 +2081,6 @@ Tcl_GetBoolFromObj( } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); - /* Don't try to convert index to a list */ - if (!TclHasInternalRep(objPtr, &tclIndexType) - && (TclMaxListLength(TclGetString(objPtr), TCL_INDEX_NONE, NULL) > 1)) { - goto listRep; - } return TCL_ERROR; } @@ -2792,12 +2787,6 @@ Tcl_GetLongFromObj( } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); - /* Don't try to convert index or boolean's to a list */ - if (!TclHasInternalRep(objPtr, &tclIndexType) - && !TclHasInternalRep(objPtr, &tclBooleanType) - && (TclMaxListLength(TclGetString(objPtr), TCL_INDEX_NONE, NULL) > 1)) { - goto listRep; - } return TCL_ERROR; } @@ -3116,12 +3105,6 @@ Tcl_GetWideIntFromObj( } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); - /* Don't try to convert index or boolean's to a list */ - if (!TclHasInternalRep(objPtr, &tclIndexType) - && !TclHasInternalRep(objPtr, &tclBooleanType) - && (TclMaxListLength(TclGetString(objPtr), TCL_INDEX_NONE, NULL) > 1)) { - goto listRep; - } return TCL_ERROR; } @@ -3811,12 +3794,6 @@ Tcl_GetNumberFromObj( } } while (TCL_OK == TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); - /* Don't try to convert index or boolean's to a list */ - if (!TclHasInternalRep(objPtr, &tclIndexType) - && !TclHasInternalRep(objPtr, &tclBooleanType) - && (TclMaxListLength(TclGetString(objPtr), TCL_INDEX_NONE, NULL) > 1)) { - goto listRep; - } return TCL_ERROR; } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index c6778ce..f93c91b 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1525,11 +1525,15 @@ TclParseNumber( if (status != TCL_OK) { if (interp != NULL) { - Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", + Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got ", expected); - - Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); + if (TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) { + Tcl_AppendToObj(msg, "a list", -1); + } else { + Tcl_AppendToObj(msg, "\"", -1); + Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); + Tcl_AppendToObj(msg, "\"", -1); + } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL); } diff --git a/tests/binary.test b/tests/binary.test index 5467072..be133df 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -312,7 +312,7 @@ test binary-8.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-8.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format c $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-8.11 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format c1 $a @@ -351,7 +351,7 @@ test binary-9.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-9.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format s $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-9.12 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format s1 $a @@ -390,7 +390,7 @@ test binary-10.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-10.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format S $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-10.12 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format S1 $a @@ -432,7 +432,7 @@ test binary-11.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-11.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format i $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-11.13 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format i1 $a @@ -474,7 +474,7 @@ test binary-12.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-12.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format I $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-12.13 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format I1 $a @@ -1814,7 +1814,7 @@ test binary-48.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-48.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format t $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-48.18 {Tcl_BinaryObjCmd: format} bigEndian { set a {0x50 0x51} binary format t1 $a @@ -1861,7 +1861,7 @@ test binary-49.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-49.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} binary format n $a -} -result "expected integer but got \"0x50 0x51\"" +} -result "expected integer but got a list" test binary-49.13 {Tcl_BinaryObjCmd: format} littleEndian { set a {0x50 0x51} binary format n1 $a diff --git a/tests/get.test b/tests/get.test index b0762ed..d5d3ca1 100644 --- a/tests/get.test +++ b/tests/get.test @@ -88,7 +88,7 @@ test get-3.1 {Tcl_GetInt(FromObj), bad numbers} { lappend result [catch {format %ld $num} msg] $msg } set result -} {0 1 0 1 1 {expected integer but got "++1"} 1 {expected integer but got "+-1"} 1 {expected integer but got "-+1"} 0 -1 1 {expected integer but got "--1"} 1 {expected integer but got "- +1"} 0 12345678987654321 1 {expected integer but got "++12345678987654321"}} +} {0 1 0 1 1 {expected integer but got "++1"} 1 {expected integer but got "+-1"} 1 {expected integer but got "-+1"} 0 -1 1 {expected integer but got "--1"} 1 {expected integer but got a list} 0 12345678987654321 1 {expected integer but got "++12345678987654321"}} test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { set result "" set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] -- cgit v0.12 From 8a6a994a76541bd5e7d673a23433889d4fa9a9f4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Sep 2024 22:09:11 +0000 Subject: TclMaxListLength() is already checked for within SetDoubeFromAny() --- generic/tclObj.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index ea900a2..6177d8b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2481,12 +2481,6 @@ Tcl_GetDoubleFromObj( goto listRep; } } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); - /* Don't try to convert index or boolean's to a list */ - if (!TclHasInternalRep(objPtr, &tclIndexType) - && !TclHasInternalRep(objPtr, &tclBooleanType) - && (TclMaxListLength(TclGetString(objPtr), TCL_INDEX_NONE, NULL) > 1)) { - goto listRep; - } return TCL_ERROR; } -- cgit v0.12 From 880a3b1ea5761e65ed0ff07defdef1d6839cb780 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Oct 2024 15:17:01 +0000 Subject: Do an additional check, before declaring something "a list" --- generic/tclExecute.c | 5 ++++- generic/tclStrToD.c | 6 +++++- tests/expr.test | 8 ++++---- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index dc5d315..93fc486 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9121,8 +9121,11 @@ IllegalExprOperandType( } } Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(opndPtr, lengthProc); + Tcl_Size objcPtr; + Tcl_Obj **objvPtr; if ((lengthProc && lengthProc(opndPtr) > 1) - || TclMaxListLength(TclGetString(opndPtr), TCL_INDEX_NONE, NULL) > 1) { + || ((TclMaxListLength(TclGetString(opndPtr), TCL_INDEX_NONE, NULL) > 1) + && (Tcl_ListObjGetElements(NULL, opndPtr, &objcPtr, &objvPtr) == TCL_OK))) { goto listRep; } description = "non-numeric string"; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index f93c91b..460df40 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1527,7 +1527,11 @@ TclParseNumber( if (interp != NULL) { Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got ", expected); - if (TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) { + Tcl_Size argc; + const char **argv; + if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) + && Tcl_SplitList(NULL, bytes, &argc, &argv) == TCL_OK) { + Tcl_Free(argv); Tcl_AppendToObj(msg, "a list", -1); } else { Tcl_AppendToObj(msg, "\"", -1); diff --git a/tests/expr.test b/tests/expr.test index 190e963..67a11e2 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -505,8 +505,8 @@ test expr-11.14 {CompileAddExpr: runtime error} { list [catch {expr {24.0+[lseq 2 4]}} msg] $msg } {1 {cannot use a list as right operand of "+"}} test expr-11.15 {CompileAddExpr: runtime error} { - list [catch {expr {{1 2 3}+24.0}} msg] $msg -} {1 {cannot use a list as left operand of "+"}} + list [catch {expr {{1 2 "}+24.0}} msg] $msg +} {1 {cannot use non-numeric string "1 2 "" as left operand of "+"}} test expr-11.16 {CompileAddExpr: runtime error} { list [catch {expr {~[dict create foo bar]}} msg] $msg } {1 {cannot use a list as operand of "~"}} @@ -7240,8 +7240,8 @@ test expr-47.14 {isqrt() - lseq} { list [catch {expr {isqrt([lseq 1 3])}} result] $result } {1 {expected number but got a list}} test expr-47.15 {isqrt() - lseq} { - list [catch {expr {isqrt({1 2 3})}} result] $result -} {1 {expected number but got a list}} + list [catch {expr {isqrt({1 2 "})}} result] $result +} {1 {expected number but got "1 2 ""}} test expr-47.16 {isqrt() - lseq} { list [catch {expr {isqrt([dict create foo bar])}} result] $result } {1 {expected number but got a list}} -- cgit v0.12