$| = 1;
BEGIN { require './test.pl' }
-plan tests => 4882;
+plan tests => 4980;
use Scalar::Util qw(tainted);
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;
# 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
# 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 '='.
. '$_[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)) {
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/',
"<$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) =
$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;
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 =~ /\+\+|--/;
::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<B using B<=> 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');
+}
+
+
# EOF
https://perl5.git.perl.org / perl5.git / blobdiff