tcltk/tcl
1
0
Fork 0
mirror of https://github.com/tcltk/tcl.git synced 2026-05-29 00:27:49 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

Follow-up for [0439e1e1a3]: Slow detection of illegal expr argument. Same fix in more places. Only use "list" for real lists

Browse Source
This commit is contained in:
jan.nijtmans
2024-10-08 22:36:25 +00:00
parent aa4357dad8 e301c28ca2
commit b2ccc20dee
11 changed files with 109 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
generic/tclExecute.c
View File

@@ -9121,7 +9121,11 @@ IllegalExprOperandType(
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(opndPtr, lengthProc);
if (lengthProc && lengthProc(opndPtr) > 1) {
Tcl_Size objcPtr;
Tcl_Obj **objvPtr;
if ((lengthProc && lengthProc(opndPtr) > 1)
|| ((TclMaxListLength(TclGetString(opndPtr), TCL_INDEX_NONE, NULL) > 1)
&& (Tcl_ListObjGetElements(NULL, opndPtr, &objcPtr, &objvPtr) == TCL_OK))) {
goto listRep;
}
description = "non-numeric string";

72
generic/tclObj.c
View File

@@ -2006,6 +2006,7 @@ Tcl_GetBoolFromObj(
char *charPtr) /* Place to store resulting boolean. */
{
int result;
Tcl_Size length;
if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
result = -1;
@@ -2061,6 +2062,22 @@ Tcl_GetBoolFromObj(
}
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("expected boolean value%s but got a list",
(flags & TCL_NULL_OK) ? " or \"\"" : ""));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
@@ -2421,6 +2438,7 @@ Tcl_GetDoubleFromObj(
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, &tclDoubleType)) {
if (isnan(objPtr->internalRep.doubleValue)) {
@@ -2446,6 +2464,22 @@ Tcl_GetDoubleFromObj(
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("expected floating-point number but got a list", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
@@ -2650,6 +2684,7 @@ Tcl_GetLongFromObj(
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
Tcl_Size length;
do {
#ifdef TCL_WIDE_INT_IS_LONG
if (TclHasInternalRep(objPtr, &tclIntType)) {
@@ -2729,6 +2764,21 @@ Tcl_GetLongFromObj(
}
return TCL_ERROR;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected integer but got a list", -1));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
@@ -2979,6 +3029,7 @@ Tcl_GetWideIntFromObj(
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, &tclIntType)) {
*wideIntPtr = objPtr->internalRep.wideValue;
@@ -3031,6 +3082,21 @@ Tcl_GetWideIntFromObj(
}
return TCL_ERROR;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 0) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected integer but got a list", -1));
}
return TCL_ERROR;
}
}
Tcl_ObjTypeLengthProc *lengthProc = TclObjTypeHasProc(objPtr, lengthProc);
if (lengthProc && lengthProc(objPtr) != 1) {
goto listRep;
}
} while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
@@ -3722,12 +3788,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;
}

16
generic/tclStrToD.c
View File

@@ -1525,11 +1525,19 @@ 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);
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);
Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
}
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL);
}

22
tests/binary.test
View File

@@ -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
@@ -531,7 +531,7 @@ test binary-13.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format f $a
} -result "expected floating-point number but got \"1.6 3.4\""
} -result "expected floating-point number but got a list"
test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format f1 $a
@@ -592,7 +592,7 @@ test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format d $a
} -result "expected floating-point number but got \"1.6 3.4\""
} -result "expected floating-point number but got a list"
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format d1 $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
@@ -1944,7 +1944,7 @@ test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format q $a
} -result "expected floating-point number but got \"1.6 3.4\""
} -result "expected floating-point number but got a list"
test binary-51.16 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format Q1 $a
@@ -2006,7 +2006,7 @@ test binary-53.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {1.6 3.4}
binary format r $a
} -result "expected floating-point number but got \"1.6 3.4\""
} -result "expected floating-point number but got a list"
test binary-53.18 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format R1 $a

2
tests/dict.test
View File

@@ -1004,7 +1004,7 @@ test dict-17.12 {dict filter command: script} -returnCodes error -body {
}
} -cleanup {
unset k v
} -result {expected boolean value but got "a b"}
} -result {expected boolean value but got a list}
test dict-17.13 {dict filter command: script} -body {
list [catch {dict filter {a b} script {k v} {error x}} msg] $msg \
$::errorInfo

2
tests/expr-old.test
View File

@@ -896,7 +896,7 @@ test expr-old-34.2 {errors in math functions} -body {
} -returnCodes error -match glob -result *
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {expected floating-point number but got "a b"}}
} {1 {expected floating-point number but got a list}}
test expr-old-34.4 {errors in math functions} -body {
expr hypot(1.0 2.0)
} -returnCodes error -match glob -result *

8
tests/expr.test
View File

@@ -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 non-numeric string "1 2 3" 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}}

8
tests/get.test
View File

@@ -41,7 +41,7 @@ test get-1.5 {Tcl_GetInt procedure} testgetint {
} {0 60}
test get-1.6 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 {16 x}} msg] $msg
} {1 {expected integer but got "16 x"}}
} {1 {expected integer but got a list}}
test get-1.7 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
@@ -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"]
@@ -96,7 +96,7 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
lappend result [catch {format %g $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got a list}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} {
@@ -110,7 +110,7 @@ test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}}
} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got a list} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}}
test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint {
lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x0_a " 0b1111_1111 " 0_07 " " 0o1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 0x_b 0o_2_0 0o2__3_4} {

4
tests/if.test
View File

@@ -181,7 +181,7 @@ test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} -setup {
if {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a
} -result {expected boolean value but got "0 < 3"}
} -result {expected boolean value but got a list}
test if-2.1 {TclCompileIfCmd: "elseif" after if/elseif test} -setup {
set a {}
@@ -753,7 +753,7 @@ test if-5.17 {if cmd with computed command names: if/elseif test in quotes} -set
$z {"0 < 3"} {set a 1}
} -returnCodes error -cleanup {
unset a z
} -result {expected boolean value but got "0 < 3"}
} -result {expected boolean value but got a list}
test if-6.1 {if cmd with computed command names: "elseif" after if/elseif test} -setup {
set a {}

2
tests/incr-old.test
View File

@@ -85,7 +85,7 @@ test incr-old-2.9 {incr errors} {
test incr-old-2.10 {incr errors} {
set x {20 x}
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}
} {1 {expected integer but got a list}}
# cleanup
::tcltest::cleanupTests

4
tests/incr.test
View File

@@ -553,13 +553,13 @@ test incr-2.31 {incr command (compiled): bad increment} {
"incr x 1a"}}
test incr-2.32 {incr command (compiled): bad pure list increment} {
list [catch {incr x [list 1 2]} msg] $msg $::errorInfo
} {1 {expected integer but got "1 2"} {expected integer but got "1 2"
} {1 {expected integer but got a list} {expected integer but got a list
(reading increment)
invoked from within
"incr x [list 1 2]"}}
test incr-2.33 {incr command (compiled): bad pure dict increment} {
list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo
} {1 {expected integer but got "1 2"} {expected integer but got "1 2"
} {1 {expected integer but got a list} {expected integer but got a list
(reading increment)
invoked from within
"incr x [dict create 1 2]"}}