X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3bc4ee4c5aa3ed1ba3b33fb9d35f9196144d5420..78325d7a7e6183fba46cbfb1dbd40def2996b940:/lib/overload.t diff --git a/lib/overload.t b/lib/overload.t index 7d4dbff..5d6e38d 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -47,7 +47,8 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead package main; $| = 1; -use Test::More tests => 4880; +BEGIN { require './test.pl' } +plan tests => 5037; use Scalar::Util qw(tainted); @@ -296,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_!_'); @@ -602,8 +603,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; @@ -706,13 +706,7 @@ is($c, "bareword"); sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } } -# XXX iterator overload not intended to work with CORE::GLOBAL? -if (defined &CORE::GLOBAL::glob) { - is('1', '1'); - is('1', '1'); - is('1', '1'); -} -else { +{ my $iter = iterator->new(5); my $acc = ''; my $out; @@ -941,25 +935,25 @@ 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/); } { @@ -1372,11 +1366,11 @@ foreach my $op (qw(<=> == != < <= > >=)) { $obj = bless do {my $a; \$a}, 'Shklitza'; $ref = $obj; - is ($obj, "CLiK KLAK"); - is ($ref, "CLiK KLAK"); + is ("$obj", "CLiK KLAK"); + is ("$ref", "CLiK KLAK"); weaken $ref; - is ($ref, "CLiK KLAK"); + is ("$ref", "CLiK KLAK"); bless $obj, 'Ksshfwoom'; @@ -1681,7 +1675,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 @@ -1690,7 +1684,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 '='. @@ -1798,10 +1792,9 @@ foreach my $op (qw(<=> == != < <= > >=)) { # note: this is testing unary qr, not binary =~ $subs{qr} = '(qr/%s/)'; - # XXX TODO qr overload with fallback calls "" and FETCH too often - #push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ]; - push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")("")', - [ 1, 2, 0, 1, 5, 0 ], 0 ]; + 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; @@ -1814,21 +1807,11 @@ 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)) { - # XXX TODO -X overload with fallback calls FETCH too often - # XXX and -t calls "" too often too - #push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', [ 1, 2, 0 ], 0 ]; - if ($_ eq 't') { - push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")("")', - [ 1, 2, 0, 1, 5, 0 ], 0 ]; - } - else { - push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', - [ 1, 2, 0, 1, 3, 0 ], 0 ]; - } + push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', [ 1, 2, 0 ], 0 ]; } $subs{'${}'} = '%s'; @@ -1839,7 +1822,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}', @@ -1851,7 +1834,11 @@ foreach my $op (qw(<=> == != < <= > >=)) { push @tests, [ \*RT57012A, '*RT57012B = *{%s}; our $RT57012B', '(*{})', undef, [ 1, 1, 0 ], 0 ]; - # XXX TODO: '<>' + my $iter_text = ("some random text\n" x 100) . $^X; + open my $iter_fh, '<', \$iter_text + or die "open of \$iter_text gave ($!)\n"; + $subs{'<>'} = '<$iter_fh>'; + push @tests, [ $iter_fh, '<%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/', @@ -1952,7 +1939,6 @@ foreach my $op (qw(<=> == != < <= > >=)) { "<$plain_term> taint of expected return"); for my $ov_pkg (qw(RT57012_OV RT57012_OV_FB)) { - # the deref ops don't support fallback next if $ov_pkg eq 'RT57012_OV_FB' and not defined $exp_fb_funcs; my ($exp_fetch_a, $exp_fetch_s, $exp_store) = @@ -1965,7 +1951,9 @@ foreach my $op (qw(<=> == != < <= > >=)) { $ta[0] = bless [ $tainted_val ], $ov_pkg; my $oload = bless [ $tainted_val ], $ov_pkg; - for my $var ('$ta[0]', '$ts', '$oload') { + for my $var ('$ta[0]', '$ts', '$oload', + ($sub_term eq '<%s>' ? '${ts}' : ()) + ) { $funcs = ''; $fetches = 0; @@ -1975,7 +1963,7 @@ foreach my $op (qw(<=> == != < <= > >=)) { my $desc = "<$res_term> $ov_pkg" ; my $res = 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 =~ /\+\+|--/; @@ -2003,4 +1991,210 @@ foreach my $op (qw(<=> == != < <= > >=)) { } } +# Test overload from the main package +fresh_perl_is + '$^W = 1; use overload q\""\ => sub {"ning"}; print bless []', + 'ning', + { switches => ['-wl'], stderr => 1 }, + 'use overload from the main package' +; + +{ + package blessed_methods; + use overload '+' => sub {}; + bless overload::Method __PACKAGE__,'+'; + eval { overload::Method __PACKAGE__,'+' }; + ::is($@, '', 'overload::Method and blessed overload methods'); +} + +{ + # fallback to 'cmp' and '<=>' with heterogeneous operands + # [perl #71286] + my $not_found = 'no method found'; + my $used = 0; + package CmpBase; + sub new { + my $n = $_[1] || 0; + bless \$n, ref $_[0] || $_[0]; + } + sub cmp { + $used = \$_[0]; + (${$_[0]} <=> ${$_[1]}) * ($_[2] ? -1 : 1); + } + + package NCmp; + use base 'CmpBase'; + use overload '<=>' => 'cmp'; + + package SCmp; + use base 'CmpBase'; + use overload 'cmp' => 'cmp'; + + package main; + my $n = NCmp->new(5); + my $s = SCmp->new(3); + my $res; + + eval { $res = $n > $s; }; + $res = $not_found if $@ =~ /$not_found/; + is($res, 1, 'A>B using A<=> when B overloaded, no B<=>'); + + eval { $res = $s < $n; }; + $res = $not_found if $@ =~ /$not_found/; + is($res, 1, 'A when A overloaded, no A<=>'); + + eval { $res = $s lt $n; }; + $res = $not_found if $@ =~ /$not_found/; + is($res, 1, 'A lt B using A:cmp when B overloaded, no B:cmp'); + + eval { $res = $n gt $s; }; + $res = $not_found if $@ =~ /$not_found/; + is($res, 1, 'A gt B using B:cmp when A overloaded, no A:cmp'); + + my $o = NCmp->new(9); + $res = $n < $o; + is($used, \$n, 'A < B uses <=> from A in preference to B'); + + my $t = SCmp->new(7); + $res = $s lt $t; + is($used, \$s, 'A lt B uses cmp from A in preference to B'); +} + +{ + # Combinatorial testing of 'fallback' and 'nomethod' + # [perl #71286] + package NuMB; + use overload '0+' => sub { ${$_[0]}; }, + '""' => 'str'; + sub new { + my $self = shift; + my $n = @_ ? shift : 0; + bless my $obj = \$n, ref $self || $self; + } + sub str { + no strict qw/refs/; + my $s = "(${$_[0]} "; + $s .= "nomethod, " if defined ${ref($_[0]).'::(nomethod'}; + my $fb = ${ref($_[0]).'::()'}; + $s .= "fb=" . (defined $fb ? 0 + $fb : 'undef') . ")"; + } + sub nomethod { "${$_[0]}.nomethod"; } + + # create classes for tests + package main; + my @falls = (0, 'undef', 1); + my @nomethods = ('', 'nomethod'); + my $not_found = 'no method found'; + for my $fall (@falls) { + for my $nomethod (@nomethods) { + my $nomethod_decl = $nomethod + ? $nomethod . "=>'nomethod'," : ''; + eval qq{ + package NuMB$fall$nomethod; + use base qw/NuMB/; + use overload $nomethod_decl + fallback => $fall; + }; + } + } + + # operation and precedence of 'fallback' and 'nomethod' + # for all combinations with 2 overloaded operands + for my $nomethod2 (@nomethods) { + for my $nomethod1 (@nomethods) { + for my $fall2 (@falls) { + my $pack2 = "NuMB$fall2$nomethod2"; + for my $fall1 (@falls) { + my $pack1 = "NuMB$fall1$nomethod1"; + my ($test, $out, $exp); + eval qq{ + my \$x = $pack1->new(2); + my \$y = $pack2->new(3); + \$test = "\$x" . ' * ' . "\$y"; + \$out = \$x * \$y; + }; + $out = $not_found if $@ =~ /$not_found/; + $exp = $nomethod1 ? '2.nomethod' : + $nomethod2 ? '3.nomethod' : + $fall1 eq '1' && $fall2 eq '1' ? 6 + : $not_found; + is($out, $exp, "$test --> $exp"); + } + } + } + } + + # operation of 'fallback' and 'nomethod' + # where the other operand is not overloaded + for my $nomethod (@nomethods) { + for my $fall (@falls) { + my ($test, $out, $exp); + eval qq{ + my \$x = NuMB$fall$nomethod->new(2); + \$test = "\$x" . ' * 3'; + \$out = \$x * 3; + }; + $out = $not_found if $@ =~ /$not_found/; + $exp = $nomethod ? '2.nomethod' : + $fall eq '1' ? 6 + : $not_found; + is($out, $exp, "$test --> $exp"); + + eval qq{ + my \$x = NuMB$fall$nomethod->new(2); + \$test = '3 * ' . "\$x"; + \$out = 3 * \$x; + }; + $out = $not_found if $@ =~ /$not_found/; + is($out, $exp, "$test --> $exp"); + } + } +} + +# since 5.6 overloaded <> was leaving an extra arg on the stack! + +{ + package Iter1; + use overload '<>' => sub { 11 }; + package main; + my $a = bless [], 'Iter1'; + my $x; + my @a = (10, ($x = <$a>), 12); + is ($a[0], 10, 'Iter1: a[0]'); + is ($a[1], 11, 'Iter1: a[1]'); + is ($a[2], 12, 'Iter1: a[2]'); + @a = (10, ($x .= <$a>), 12); + is ($a[0], 10, 'Iter1: a[0] concat'); + is ($a[1], 1111, 'Iter1: a[1] concat'); + 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'; +} + +{ # undefining the overload stash -- KEEP THIS TEST LAST + package ant; + use overload '+' => 'onion'; + $_ = \&overload::nil; + undef %overload::; + bless[]; + ::ok(1, 'no crash when undefining %overload::'); +} + # EOF