X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/029af4cfd939699e66ee8aa043a304c8724a2303..d4a6f307a837e59c86cb6f6d9bb31984d15500b8:/lib/overload.t diff --git a/lib/overload.t b/lib/overload.t index 89d8af7..329b6c7 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 4983; +plan tests => 5059; use Scalar::Util qw(tainted); @@ -297,7 +297,7 @@ like($@, qr/no method found/); bless \$x, Oscalar; $na = eval { ~$a }; # Hash updated -warn "`$na', $@" if $@; +warn "'$na', $@" if $@; ok !$@; is($na, '_!_xx_!_'); @@ -935,25 +935,37 @@ unless ($aaa) { } { - # check the `$_[0]' is not an overloadable type warning + # check the '$_[0]' is not an overloadable type warning my $a = "" ; local $SIG{__WARN__} = sub {$a = $_[0]} ; $x = eval ' overload::constant "fred" => sub {} ; ' ; is($a, ""); use warnings 'overload' ; $x = eval ' overload::constant "fred" => sub {} ; ' ; - like($a, qr/^`fred' is not an overloadable type at/); + like($a, qr/^'fred' is not an overloadable type at/); } { - # check the `$_[1]' is not a code reference warning + # check the '$_[1]' is not a code reference warning my $a = "" ; local $SIG{__WARN__} = sub {$a = $_[0]} ; $x = eval ' overload::constant "integer" => 1; ' ; is($a, ""); use warnings 'overload' ; $x = eval ' overload::constant "integer" => 1; ' ; - like($a, qr/^`1' is not a code reference at/); + like($a, qr/^'1' is not a code reference at/); +} + +{ + # check the invalid argument warning [perl #74098] + my $a = "" ; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + $x = eval ' use overload "~|_|~" => sub{} ' ; + is($a, ""); + use warnings 'overload' ; + $x = eval ' use overload "~|_|~" => sub{} ' ; + like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /, + 'invalid arg warning'); } { @@ -1188,17 +1200,26 @@ foreach my $op (qw(<=> == != < <= > >=)) { # doesn't look like a regex ok("x" =~ $x, "qr-only matches"); ok("y" !~ $x, "qr-only doesn't match what it shouldn't"); + ok("x" =~ /^(??{$x})$/, "qr-only with ?? matches"); + ok("y" !~ /^(??{$x})$/, "qr-only with ?? doesn't match what it shouldn't"); ok("xx" =~ /x$x/, "qr-only matches with concat"); like("$x", qr/^QRonly=ARRAY/, "qr-only doesn't have string overload"); my $qr = bless qr/y/, "QRonly"; ok("x" =~ $qr, "qr with qr-overload uses overload"); ok("y" !~ $qr, "qr with qr-overload uses overload"); + { + local $::TODO = '?? fails with "qr with qr"' ; + ok("x" =~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload"); + ok("y" !~ /^(??{$qr})$/, "qr with qr-overload with ?? uses overload"); + } is("$qr", "".qr/y/, "qr with qr-overload stringify"); my $rx = $$qr; ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match"); ok("x" !~ $rx, "bare rx with qr-overload doesn't overload match"); + ok("y" =~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match"); + ok("x" !~ /^(??{$rx})$/, "bare rx with qr-overload with ?? doesn't overload match"); is("$rx", "".qr/y/, "bare rx with qr-overload stringify"); } { @@ -1793,6 +1814,8 @@ foreach my $op (qw(<=> == != < <= > >=)) { # note: this is testing unary qr, not binary =~ $subs{qr} = '(qr/%s/)'; push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ]; + push @tests, [ chr 256, 'chr(256) =~ (%s)', '(qr)', '("")', + [ 1, 2, 0 ], 0 ]; $e = '"abc" ~~ (%s)'; $subs{'~~'} = $e; @@ -2186,6 +2209,45 @@ fresh_perl_is 'Error message when sub stub is encountered'; } +{ + # check that the right number of stringifications + # and the correct un-utf8-ifying happen on regex compile + package utf8_match; + my $c; + use overload '""' => sub { $c++; $_[0][0] ? "^\x{100}\$" : "^A\$"; }; + my $o = bless [0], 'utf8_match'; + + $o->[0] = 0; + $c = 0; + ::ok("A" =~ "^A\$", "regex stringify utf8=0 ol=0 bytes=0"); + ::ok("A" =~ $o, "regex stringify utf8=0 ol=1 bytes=0"); + ::is($c, 1, "regex stringify utf8=0 ol=1 bytes=0 count"); + + $o->[0] = 1; + $c = 0; + ::ok("\x{100}" =~ "^\x{100}\$", + "regex stringify utf8=1 ol=0 bytes=0"); + ::ok("\x{100}" =~ $o, "regex stringify utf8=1 ol=1 bytes=0"); + ::is($c, 1, "regex stringify utf8=1 ol=1 bytes=0 count"); + + use bytes; + + $o->[0] = 0; + $c = 0; + ::ok("A" =~ "^A\$", "regex stringify utf8=0 ol=0 bytes=1"); + ::ok("A" =~ $o, "regex stringify utf8=0 ol=1 bytes=1"); + ::is($c, 1, "regex stringify utf8=0 ol=1 bytes=1 count"); + + $o->[0] = 1; + $c = 0; + ::ok("\xc4\x80" =~ "^\x{100}\$", + "regex stringify utf8=1 ol=0 bytes=1"); + ::ok("\xc4\x80" =~ $o, "regex stringify utf8=1 ol=1 bytes=1"); + ::is($c, 1, "regex stringify utf8=1 ol=1 bytes=1 count"); + + +} + { # undefining the overload stash -- KEEP THIS TEST LAST package ant; use overload '+' => 'onion'; @@ -2195,4 +2257,39 @@ fresh_perl_is ::ok(1, 'no crash when undefining %overload::'); } +# [perl #40333] +# overload::Overloaded should not use a ->can designed for autoloading. +# This example attempts to be as realistic as possible. The o class has a +# default singleton object, but can have instances, too. The proxy class +# represents proxies for o objects, but class methods delegate to the +# singleton. +# overload::Overloaded used to return incorrect results for proxy objects. +package proxy { + sub new { bless [$_[1]], $_[0] } + sub AUTOLOAD { + our $AUTOLOAD =~ s/.*:://; + &_self->$AUTOLOAD; + } + sub can { SUPER::can{@_} || &_self->can($_[1]) } + sub _self { ref $_[0] ? $_[0][0] : $o::singleton } +} +package o { use overload '""' => sub { 'keck' }; + sub new { bless[], $_[0] } + our $singleton = o->new; } +ok !overload::Overloaded(new proxy new o), + 'overload::Overloaded does not incorrectly return true for proxy classes'; + +# Another test, based on the type of explosive test class for which +# perl #40333 was filed. +{ + package broken_can; + sub can {} + use overload '""' => sub {"Ahoy!"}; + + package main; + my $obj = bless [], 'broken_can'; + ok(overload::Overloaded($obj)); +} + + # EOF