diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index ff9bf115b..c6440be35 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -939,14 +939,26 @@ sub unlike { my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); -# Bad, these are not comparison operators. Should we include more? -my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); +# Allowlist of valid Perl comparison operators. +# Matches Test2::Tools::ClassicCompare::%OPS for consistency. +my %cmp_ok_al = map { ( $_, 1 ) } ( + # numeric + "<", "<=", ">", ">=", "==", "!=", "<=>", + # string + "eq", "ne", "gt", "lt", "ge", "le", "cmp", "=~", "!~", + # logic + "&&", "||", "xor", "or", "and", "//", + # bitwise + "&", "|", + # match + "~~", +); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $ctx = $self->ctx; - if ($cmp_ok_bl{$type}) { + if (!$cmp_ok_al{$type}) { $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } diff --git a/t/Legacy/478-cmp_ok_hash.t b/t/Legacy/478-cmp_ok_hash.t index 811835b9d..c0d70b097 100644 --- a/t/Legacy/478-cmp_ok_hash.t +++ b/t/Legacy/478-cmp_ok_hash.t @@ -8,34 +8,9 @@ my $got = 0; cmp_ok($got, 'eq', $want, "Passes on correct comparison"); -my ($res, @ok, @diag, @warn); -{ - no warnings 'redefine'; - local *Test::Builder::ok = sub { - my ($tb, $ok, $name) = @_; - push @ok => $ok; - return $ok; - }; - local *Test::Builder::diag = sub { - my ($tb, @d) = @_; - push @diag => @d; - }; - local $SIG{__WARN__} = sub { - push @warn => @_; - }; - $res = cmp_ok($got, '#eq', $want, "You shall not pass!"); -} - -ok(!$res, "Did not pass"); - -is(@ok, 1, "1 result"); -ok(!$ok[0], "result is false"); - -# We only care that it mentions a syntax error. -like(join("\n" => @diag), qr/syntax error at \(eval in cmp_ok\)/, "Syntax error"); - -# We are not going to inspect the warning because it is not super predictable, -# and changes with eval specifics. -ok(@warn, "We got warnings"); +# Invalid operator '#eq' should be rejected by the allowlist +my $threw = !eval { cmp_ok($got, '#eq', $want, "You shall not pass!"); 1 }; +ok($threw, "Invalid operator throws"); +like($@, qr/#eq is not a valid comparison operator in cmp_ok\(\)/, "Error message mentions invalid operator"); done_testing; diff --git a/t/Legacy/cmp_ok.t b/t/Legacy/cmp_ok.t index 3f38e0e87..46ab131eb 100755 --- a/t/Legacy/cmp_ok.t +++ b/t/Legacy/cmp_ok.t @@ -67,9 +67,6 @@ my @Tests = ( [1, '==', 2], ["a", "eq", "b"], ["a", "eq", "a"], - [1, "+", 1], - [1, "-", 1], - [$cmp, '==', 42], [$cmp, 'eq', "foo"], [$ify, 'eq', "bar"], @@ -77,8 +74,12 @@ my @Tests = ( [$part, '!=', 0, 'expected: anything else'], - [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], + # Operators rejected by allowlist + [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], + [1, "+", 1, "+ is not a valid comparison operator in cmp_ok()"], + [1, "-", 1, "- is not a valid comparison operator in cmp_ok()"], + [1, "*", 1, "* is not a valid comparison operator in cmp_ok()"], ); plan tests => scalar @Tests;