X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9426e1a55981168c83a030df9bce5e0b46586581..e463df90b78a57edd46d5b19a56006b28f5029d6:/lib/overload.t diff --git a/lib/overload.t b/lib/overload.t index df91544..d778776 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -47,8 +47,8 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead package main; $| = 1; -BEGIN { require './test.pl' } -plan tests => 4980; +BEGIN { require './test.pl'; require './charset_tools.pl' } +plan tests => 5215; use Scalar::Util qw(tainted); @@ -131,7 +131,7 @@ $b++; is(ref $b, "Oscalar"); is($a, "087"); -is($b, "88"); +is($b, "89"); is(ref $a, "Oscalar"); package Oscalar; @@ -142,7 +142,7 @@ $b++; is(ref $b, "Oscalar"); is($a, "087"); -is($b, "90"); +is($b, "91"); is(ref $a, "Oscalar"); $b=$a; @@ -267,11 +267,12 @@ is("$aI", "xx"); is($aI, "xx"); is("b${aI}c", "_._.b.__.xx._.__.c._"); -# Here we test blessing to a package updates hash +# Here we test that both "no overload" and +# blessing to a package update hash eval "package Oscalar; no overload '.'"; -is("b${a}", "_.b.__.xx._"); +is("b${a}", "bxx"); $x="1"; bless \$x, Oscalar; is("b${a}c", "bxxc"); @@ -291,20 +292,20 @@ like($@, qr/no method found/); eval "package Oscalar; sub comple; use overload '~' => 'comple'"; -$na = eval { ~$a }; # Hash was not updated -like($@, qr/no method found/); +$na = eval { ~$a }; +is($@, ''); bless \$x, Oscalar; $na = eval { ~$a }; # Hash updated -warn "`$na', $@" if $@; +warn "'$na', $@" if $@; ok !$@; is($na, '_!_xx_!_'); $na = 0; -$na = eval { ~$aI }; # Hash was not updated -like($@, qr/no method found/); +$na = eval { ~$aI }; +is($@, ''); bless \$x, OscalarI; @@ -316,8 +317,8 @@ is($na, '_!_xx_!_'); eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; -$na = eval { $aI >> 1 }; # Hash was not updated -like($@, qr/no method found/); +$na = eval { $aI >> 1 }; +is($@, ''); bless \$x, OscalarI; @@ -603,8 +604,7 @@ is($c, "bareword"); } sub TIESCALAR { my $pack = shift; $pack->new(@_) } sub FETCH { shift } - sub nop { } # Around a bug - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + sub vars { my $p = shift; tie($_, $p) foreach @_; } sub STORE { my $obj = shift; $#$obj = 1; @@ -936,25 +936,42 @@ 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{} ' ; + eval ' no overload "~|_|~" ' ; + is($a, ""); + use warnings 'overload' ; + $x = eval ' use overload "~|_|~" => sub{} ' ; + like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /, + 'invalid arg warning'); + undef $a; + eval ' no overload "~|_|~" ' ; + like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /, + 'invalid arg warning'); } { @@ -1004,7 +1021,7 @@ unless ($aaa) { main::ok($x+0 =~ qr/Recurse=ARRAY/); } -# BugID 20010422.003 +# BugID 20010422.003 (#6872) package Foo; use overload @@ -1102,18 +1119,6 @@ like ($@, qr/zap/); } { - package Numify; - use overload (qw(0+ numify fallback 1)); - - sub new { - my $val = $_[1]; - bless \$val, $_[0]; - } - - sub numify { ${$_[0]} } -} - -{ package perl31793; use overload cmp => sub { 0 }; package perl31793_fb; @@ -1134,8 +1139,20 @@ like ($@, qr/zap/); like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/); } -# These are all check that overloaded values rather than reference addresses -# are what is getting tested. +{ + package Numify; + use overload (qw(0+ numify fallback 1)); + + sub new { + my $val = $_[1]; + bless \$val, $_[0]; + } + + sub numify { ${$_[0]} } +} + +# These all check that overloaded values, rather than reference addresses, +# are what are getting tested. my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; my ($ein, $zwei) = (1, 2); @@ -1189,17 +1206,23 @@ 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"); + 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"); } { @@ -1270,6 +1293,19 @@ foreach my $op (qw(<=> == != < <= > >=)) { } { + # Check readonliness of constants, whether shared hash key + # scalars or no (brought up in bug #109744) + BEGIN { overload::constant integer => sub { "main" }; } + eval { ${\5} = 'whatever' }; + like $@, qr/^Modification of a read-only value attempted at /, + 'constant overloading makes read-only constants'; + BEGIN { overload::constant integer => sub { __PACKAGE__ }; } + eval { ${\5} = 'whatever' }; + like $@, qr/^Modification of a read-only value attempted at /, + '... even with shared hash key scalars'; +} + +{ package Sklorsh; use overload bool => sub { shift->is_cool }; @@ -1676,7 +1712,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { # how many times FETCH/STORE is called: # # Mutating ops (+=, ++ etc) trigger a copy ('='), since - # the code can't distingish between something that's been copied: + # the code can't distinguish between something that's been copied: # $a = foo->new(0); $b = $a; refcnt($$b) == 2 # and overloaded objects stored in ties which will have extra # refcounts due to the tied_obj magic and entries on the tmps @@ -1685,7 +1721,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { # This accounts for a '=', and an extra STORE. # We also have a FETCH returning the final value from the eval, # plus a FETCH in the overload subs themselves: ($_[0][0]) - # triggers one. However, tied agregates have a mechanism to prevent + # triggers one. However, tied aggregates have a mechanism to prevent # multiple fetches between STOREs, which means that the tied # hash skips doing a FETCH during '='. @@ -1794,6 +1830,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; @@ -1806,7 +1844,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { . '$_[1] eq "l" ? (-l ($f)) :' . '$_[1] eq "t" ? (-t ($f)) :' . '$_[1] eq "T" ? (-T ($f)) : 0;}'; - # Note - we don't care what these filetests return, as + # Note - we don't care what these file tests return, as # long as the tied and untied versions return the same value. # The flags below are chosen to test all uses of tryAMAGICftest_MG for (qw(r e f l t T)) { @@ -1821,7 +1859,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { $subs{'%{}'} = '%s'; push @tests, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}', - '(%{})', undef, [ 1, 2, 0 ], 0 ]; + '(%{})', undef, [ 1, 1, 0 ], 0 ]; $subs{'&{}'} = '%s'; push @tests, [ sub {99}, 'do {&{%s} for 1,2}', @@ -1838,6 +1876,9 @@ foreach my $op (qw(<=> == != < <= > >=)) { or die "open of \$iter_text gave ($!)\n"; $subs{'<>'} = '<$iter_fh>'; push @tests, [ $iter_fh, '<%s>', '(<>)', undef, [ 1, 1, 0 ], 1 ]; + push @tests, [ $iter_fh, + 'local *CORE::GLOBAL::glob = sub {}; eval q|<%s>|', + '(<>)', undef, [ 1, 1, 0 ], 1 ]; # eval should do tie, overload on its arg before checking taint */ push @tests, [ '1;', 'eval q(eval %s); $@ =~ /Insecure/', @@ -1845,6 +1886,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { for my $sub (keys %subs) { + no warnings 'experimental::smartmatch'; my $term = $subs{$sub}; my $t = sprintf $term, '$_[0][0]'; my $e ="sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {" @@ -1886,6 +1928,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { ? "-\$_[0][0]" : "$_[3](\$_[0][0])"; my $r; + no warnings 'experimental::smartmatch'; if ($use_int) { use integer; $r = eval $e; } @@ -1932,7 +1975,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { $use_int = ($int ne ''); my $plain = $tainted_val; my $plain_term = $int . sprintf $sub_term, '$plain'; - my $exp = eval $plain_term; + my $exp = do {no warnings 'experimental::smartmatch'; eval $plain_term }; diag("eval of plain_term <$plain_term> gave <$@>") if $@; is(tainted($exp), $exp_taint, "<$plain_term> taint of expected return"); @@ -1960,9 +2003,9 @@ foreach my $op (qw(<=> == != < <= > >=)) { my $res_term = $int . sprintf $sub_term, $var; my $desc = "<$res_term> $ov_pkg" ; - my $res = eval $res_term; + my $res = do { no warnings 'experimental::smartmatch'; eval $res_term }; diag("eval of res_term $desc gave <$@>") if $@; - # uniquely, the inc/dec ops return tthe original + # uniquely, the inc/dec ops return the original # ref rather than a copy, so stringify it to # find out if its tainted $res = "$res" if $res_term =~ /\+\+|--/; @@ -2022,11 +2065,11 @@ fresh_perl_is } package NCmp; - use base 'CmpBase'; + use parent '-norequire', 'CmpBase'; use overload '<=>' => 'cmp'; package SCmp; - use base 'CmpBase'; + use parent '-norequire', 'CmpBase'; use overload 'cmp' => 'cmp'; package main; @@ -2090,7 +2133,7 @@ fresh_perl_is ? $nomethod . "=>'nomethod'," : ''; eval qq{ package NuMB$fall$nomethod; - use base qw/NuMB/; + use parent '-norequire', qw/NuMB/; use overload $nomethod_decl fallback => $fall; }; @@ -2168,5 +2211,619 @@ fresh_perl_is is ($a[2], 12, 'Iter1: a[2] concat'); } +# Some tests for error messages +{ + package Justus; + use overload '+' => 'justice'; + eval {"".bless[]}; + ::like $@, qr/^Can't resolve method "justice" overloading "\+" in p(?x: + )ackage "Justus" at /, + 'Error message when explicitly named overload method does not exist'; + + package JustUs; + our @ISA = 'JustYou'; + package JustYou { use overload '+' => 'injustice'; } + "JustUs"->${\"(+"}; + eval {"".bless []}; + ::like $@, qr/^Stub found while resolving method "\?{3}" overloadin(?x: + )g "\+" in package "JustUs" at /, + '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(main::byte_utf8a_to_utf8n("\xc4\x80") =~ "^\x{100}\$", + "regex stringify utf8=1 ol=0 bytes=1"); + ::ok(main::byte_utf8a_to_utf8n("\xc4\x80") =~ $o, "regex stringify utf8=1 ol=1 bytes=1"); + ::is($c, 1, "regex stringify utf8=1 ol=1 bytes=1 count"); + + +} + +# [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)); +} + +sub eleventative::cos { 'eleven' } +sub twelvetative::abs { 'twelve' } +sub thirteentative::abs { 'thirteen' } +sub fourteentative::abs { 'fourteen' } +@eleventative::ISA = twelvetative::; +{ + my $o = bless [], 'eleventative'; + eval 'package eleventative; use overload map +($_)x2, cos=>abs=>'; + is cos $o, 'eleven', 'overloading applies to object blessed before'; + bless [], 'eleventative'; + is cos $o, 'eleven', + 'ovrld applies to previously-blessed obj after other obj is blessed'; + $o = bless [], 'eleventative'; + *eleventative::cos = sub { 'ten' }; + is cos $o, 'ten', 'method changes affect overloading'; + @eleventative::ISA = thirteentative::; + is abs $o, 'thirteen', 'isa changes affect overloading'; + bless $o, 'fourteentative'; + @fourteentative::ISA = 'eleventative'; + is abs $o, 'fourteen', 'isa changes can turn overloading on'; +} + +# no overload "fallback"; +{ package phake; + use overload fallback => 1, '""' => sub { 'arakas' }; + no overload 'fallback'; +} +$a = bless [], 'phake'; +is "$a", "arakas", + 'no overload "fallback" does not stop overload from working'; +ok !eval { () = $a eq 'mpizeli'; 1 }, + 'no overload "fallback" resets fallback to undef on overloaded class'; +{ package ent; use overload fallback => 0, abs => sub{}; + our@ISA = 'huorn'; + package huorn; + use overload fallback => 1; + package ent; + no overload "fallback"; # disable previous declaration +} +$a = bless [], ent::; +is eval {"$a"}, overload::StrVal($a), + 'no overload undoes fallback declaration completetly' + or diag $@; + +# inherited fallback +{ + package pervyy; + our @ISA = 'vtoryy'; + use overload "abs" =>=> sub {}; + package vtoryy; + use overload fallback => 1, 'sin' =>=> sub{} +} +$a = bless [], pervyy::; +is eval {"$a"}, overload::StrVal($a), + 'fallback is inherited by classes that have their own overloading' + or diag $@; + +# package separators in method names +{ + package mane; + use overload q\""\ => "bear::strength"; + use overload bool => "bear'bouillon"; +} +@bear::ISA = 'food'; +sub food::strength { 'twine' } +sub food::bouillon { 0 } +$a = bless[], mane::; +is eval { "$a" }, 'twine', ':: in method name' or diag $@; +is eval { !$a }, 1, "' in method name" or diag $@; + +# [perl #113050] Half of CPAN assumes fallback is under "()" +{ + package dodo; + use overload '+' => sub {}; + no strict; + *{"dodo::()"} = sub{}; + ${"dodo::()"} = 1; +} +$a = bless [],'dodo'; +is eval {"$a"}, overload::StrVal($a), 'fallback is stored under "()"'; + +# [perl #47119] +{ + my $context; + + { + package Splitter; + use overload '<>' => \&chars; + + sub new { + my $class = shift; + my ($string) = @_; + bless \$string, $class; + } + + sub chars { + my $self = shift; + my @chars = split //, $$self; + $context = wantarray; + return @chars; + } + } + + my $obj = Splitter->new('bar'); + + $context = 42; # not 1, '', or undef + + my @foo = <$obj>; + is($context, 1, "list context (readline list)"); + is(scalar(@foo), 3, "correct result (readline list)"); + is($foo[0], 'b', "correct result (readline list)"); + is($foo[1], 'a', "correct result (readline list)"); + is($foo[2], 'r', "correct result (readline list)"); + + $context = 42; + + my $foo = <$obj>; + ok(defined($context), "scalar context (readline scalar)"); + is($context, '', "scalar context (readline scalar)"); + is($foo, 3, "correct result (readline scalar)"); + + $context = 42; + + <$obj>; + ok(!defined($context), "void context (readline void)"); + + $context = 42; + + my @bar = <${obj}>; + is($context, 1, "list context (glob list)"); + is(scalar(@bar), 3, "correct result (glob list)"); + is($bar[0], 'b', "correct result (glob list)"); + is($bar[1], 'a', "correct result (glob list)"); + is($bar[2], 'r', "correct result (glob list)"); + + $context = 42; + + my $bar = <${obj}>; + ok(defined($context), "scalar context (glob scalar)"); + is($context, '', "scalar context (glob scalar)"); + is($bar, 3, "correct result (glob scalar)"); + + $context = 42; + + <${obj}>; + ok(!defined($context), "void context (glob void)"); +} +{ + my $context; + + { + package StringWithContext; + use overload '""' => \&stringify; + + sub new { + my $class = shift; + my ($string) = @_; + bless \$string, $class; + } + + sub stringify { + my $self = shift; + $context = wantarray; + return $$self; + } + } + + my $obj = StringWithContext->new('bar'); + + $context = 42; + + my @foo = "".$obj; + ok(defined($context), "scalar context (stringify list)"); + is($context, '', "scalar context (stringify list)"); + is(scalar(@foo), 1, "correct result (stringify list)"); + is($foo[0], 'bar', "correct result (stringify list)"); + + $context = 42; + + my $foo = "".$obj; + ok(defined($context), "scalar context (stringify scalar)"); + is($context, '', "scalar context (stringify scalar)"); + is($foo, 'bar', "correct result (stringify scalar)"); + + $context = 42; + + "".$obj; + + is($context, '', "scalar context (stringify void)"); +} +{ + my ($context, $swap); + + { + package AddWithContext; + use overload '+' => \&add; + + sub new { + my $class = shift; + my ($num) = @_; + bless \$num, $class; + } + + sub add { + my $self = shift; + my ($other, $swapped) = @_; + $context = wantarray; + $swap = $swapped; + return ref($self)->new($$self + $other); + } + + sub val { ${ $_[0] } } + } + + my $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = $obj + 7; + ok(defined($context), "scalar context (add list)"); + is($context, '', "scalar context (add list)"); + ok(defined($swap), "not swapped (add list)"); + is($swap, '', "not swapped (add list)"); + is(scalar(@foo), 1, "correct result (add list)"); + is($foo[0]->val, 13, "correct result (add list)"); + + $context = $swap = 42; + + @foo = 7 + $obj; + ok(defined($context), "scalar context (add list swap)"); + is($context, '', "scalar context (add list swap)"); + ok(defined($swap), "swapped (add list swap)"); + is($swap, 1, "swapped (add list swap)"); + is(scalar(@foo), 1, "correct result (add list swap)"); + is($foo[0]->val, 13, "correct result (add list swap)"); + + $context = $swap = 42; + + my $foo = $obj + 7; + ok(defined($context), "scalar context (add scalar)"); + is($context, '', "scalar context (add scalar)"); + ok(defined($swap), "not swapped (add scalar)"); + is($swap, '', "not swapped (add scalar)"); + is($foo->val, 13, "correct result (add scalar)"); + + $context = $swap = 42; + + my $foo = 7 + $obj; + ok(defined($context), "scalar context (add scalar swap)"); + is($context, '', "scalar context (add scalar swap)"); + ok(defined($swap), "swapped (add scalar swap)"); + is($swap, 1, "swapped (add scalar swap)"); + is($foo->val, 13, "correct result (add scalar swap)"); + + $context = $swap = 42; + + $obj + 7; + + ok(!defined($context), "void context (add void)"); + ok(defined($swap), "not swapped (add void)"); + is($swap, '', "not swapped (add void)"); + + $context = $swap = 42; + + 7 + $obj; + + ok(!defined($context), "void context (add void swap)"); + ok(defined($swap), "swapped (add void swap)"); + is($swap, 1, "swapped (add void swap)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = $obj += 7; + ok(defined($context), "scalar context (add assign list)"); + is($context, '', "scalar context (add assign list)"); + ok(!defined($swap), "not swapped and autogenerated (add assign list)"); + is(scalar(@foo), 1, "correct result (add assign list)"); + is($foo[0]->val, 13, "correct result (add assign list)"); + is($obj->val, 13, "correct result (add assign list)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my $foo = $obj += 7; + ok(defined($context), "scalar context (add assign scalar)"); + is($context, '', "scalar context (add assign scalar)"); + ok(!defined($swap), "not swapped and autogenerated (add assign scalar)"); + is($foo->val, 13, "correct result (add assign scalar)"); + is($obj->val, 13, "correct result (add assign scalar)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + $obj += 7; + + ok(defined($context), "scalar context (add assign void)"); + is($context, '', "scalar context (add assign void)"); + ok(!defined($swap), "not swapped and autogenerated (add assign void)"); + is($obj->val, 13, "correct result (add assign void)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = ++$obj; + ok(defined($context), "scalar context (add incr list)"); + is($context, '', "scalar context (add incr list)"); + ok(!defined($swap), "not swapped and autogenerated (add incr list)"); + is(scalar(@foo), 1, "correct result (add incr list)"); + is($foo[0]->val, 7, "correct result (add incr list)"); + is($obj->val, 7, "correct result (add incr list)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my $foo = ++$obj; + ok(defined($context), "scalar context (add incr scalar)"); + is($context, '', "scalar context (add incr scalar)"); + ok(!defined($swap), "not swapped and autogenerated (add incr scalar)"); + is($foo->val, 7, "correct result (add incr scalar)"); + is($obj->val, 7, "correct result (add incr scalar)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + ++$obj; + + ok(defined($context), "scalar context (add incr void)"); + is($context, '', "scalar context (add incr void)"); + ok(!defined($swap), "not swapped and autogenerated (add incr void)"); + is($obj->val, 7, "correct result (add incr void)"); +} + +# [perl #113010] +{ + { + package OnlyFallback; + use overload fallback => 0; + } + { + my $obj = bless {}, 'OnlyFallback'; + my $died = !eval { "".$obj; 1 }; + my $err = $@; + ok($died, "fallback of 0 causes error"); + like($err, qr/"\.": no method found/, "correct error"); + } + + { + package OnlyFallbackUndef; + use overload fallback => undef; + } + { + my $obj = bless {}, 'OnlyFallbackUndef'; + my $died = !eval { "".$obj; 1 }; + my $err = $@; + ok($died, "fallback of undef causes error"); + # this one tries falling back to stringify before dying + like($err, qr/"""": no method found/, "correct error"); + } + + { + package OnlyFallbackTrue; + use overload fallback => 1; + } + { + my $obj = bless {}, 'OnlyFallbackTrue'; + my $val; + my $died = !eval { $val = "".$obj; 1 }; + my $err = $@; + ok(!$died, "fallback of 1 doesn't cause error") + || diag("got error of $err"); + like($val, qr/^OnlyFallbackTrue=HASH\(/, "stringified correctly"); + } +} + +{ + # Making Regexp class overloaded: avoid infinite recursion. + # Do this in a separate process since it, well, overloads Regexp! + fresh_perl_is( + <<'EOF', +package Regexp; +use overload q{""} => sub {$_[0] }; +package main; +my $r1 = qr/1/; +my $r2 = qr/ABC$r1/; +print $r2,"\n"; +EOF + '(?^:ABC(?^:1))', + { stderr => 1 }, + 'overloaded REGEXP' + ); +} + +{ + # RT #121362 + # splitting the stash HV while rebuilding the overload cache gave + # valgrind errors. This test code triggers such a split. It doesn't + # actually test anything; its just there for valgrind to spot + # problems. + + package A_121362; + + sub stringify { } + use overload '""' => 'stringify'; + + package B_121362; + our @ISA = qw(A_121362); + + package main; + + my $x = bless { }, 'B_121362'; + + for ('a'..'z') { + delete $B_121362::{stringify}; # delete cache entry + no strict 'refs'; + *{"B_121362::$_"} = sub { }; # increase size of %B_121362 + my $y = $x->{value}; # trigger cache add to %B_121362 + } + pass("RT 121362"); +} + +package refsgalore { + use overload + '${}' => sub { \42 }, + '@{}' => sub { [43] }, + '%{}' => sub { { 44 => 45 } }, + '&{}' => sub { sub { 46 } }; +} +{ + use feature 'postderef'; + tell myio; # vivifies *myio{IO} at compile time + use constant ioref => bless *myio{IO}, refsgalore::; + is ioref->$*, 42, '(overloaded constant that is not a scalar ref)->$*'; + is ioref->[0], 43, '(ovrld constant that is not an array ref)->[0]'; + is ioref->{44}, 45, "(ovrld const that is not a hash ref)->{key}"; + is ioref->(), 46, '(overloaded constant that is not a sub ref)->()'; +} + +package xstack { use overload 'x' => sub { shift . " x " . shift }, + '""'=> sub { "xstack" } } +is join(",", 1..3, scalar((bless([], 'xstack')) x 3, 1), 4..6), + "1,2,3,1,4,5,6", + '(...)x... in void cx with x overloaded [perl #121827]'; + +package bitops { + our @o; + use overload do { + my %o; + for my $o (qw(& | ^ ~ &. |. ^. ~. &= |= ^= &.= |.= ^.=)) { + $o{$o} = sub { + ::ok !defined $_[3], "undef (or nonexistent) arg 3 for $o"; + push @o, $o, scalar @_, $_[4]//'u'; + $_[0] + } + } + %o, '=' => sub { bless [] }; + } +} +{ + use experimental 'bitwise'; + my $o = bless [], bitops::; + $_ = $o & 0; + $_ = $o | 0; + $_ = $o ^ 0; + $_ = ~$o; + $_ = $o &. 0; + $_ = $o |. 0; + $_ = $o ^. 0; + $_ = ~.$o; + $o &= 0; + $o |= 0; + $o ^= 0; + $o &.= 0; + $o |.= 0; + $o ^.= 0; + # elems are in triplets: op, length of @_, numeric? (1/u for y/n) + is "@bitops::o", '& 5 1 | 5 1 ^ 5 1 ~ 5 1 &. 3 u |. 3 u ^. 3 u ~. 3 u ' . '&= 5 1 |= 5 1 ^= 5 1 &.= 3 u |.= 3 u ^.= 3 u', + 'experimental "bitwise" ops' +} +package bitops2 { + our @o; + use overload + nomethod => sub { push @o, $_[3], scalar @_, $_[4]//'u'; $_[0] }, + '=' => sub { bless [] }; +} +{ + use experimental 'bitwise'; + my $o = bless [], bitops2::; + $_ = $o & 0; + $_ = $o | 0; + $_ = $o ^ 0; + $_ = ~$o; + $_ = $o &. 0; + $_ = $o |. 0; + $_ = $o ^. 0; + $_ = ~.$o; + $o &= 0; + $o |= 0; + $o ^= 0; + $o &.= 0; + $o |.= 0; + $o ^.= 0; + # elems are in triplets: op, length of @_, numeric? (1/u for y/n) + is "@bitops2::o", '& 5 1 | 5 1 ^ 5 1 ~ 5 1 &. 4 u |. 4 u ^. 4 u ~. 4 u ' . '&= 5 1 |= 5 1 ^= 5 1 &.= 4 u |.= 4 u ^.= 4 u', + 'experimental "bitwise" ops with nomethod' +} + +{ # undefining the overload stash -- KEEP THIS TEST LAST + package ant; + use overload '+' => 'onion'; + $_ = \&overload::nil; + undef %overload::; + ()=0+bless[]; + ::ok(1, 'no crash when undefining %overload::'); +} + # EOF