diff options
| author | Father Chrysostomos <sprout@cpan.org> | 2010-05-24 11:56:25 +0100 |
|---|---|---|
| committer | David Mitchell <davem@iabyn.com> | 2010-05-25 12:44:16 +0100 |
| commit | 6a5f8cbd14b4a44b35830907e944f1af0caeea90 (patch) | |
| tree | f71c0bf734635189c90544935d25c25bdaf403a1 /t | |
| parent | 5f26d5fd39994d2ecb568aeb7efdba685fe9a350 (diff) | |
| download | perl-6a5f8cbd14b4a44b35830907e944f1af0caeea90.tar.gz | |
Just the tests from a proposed fix for 68192
The bug was fixed in a different way by davem, but the tests
are needed as the base for a commit to follow
Diffstat (limited to 't')
| -rw-r--r-- | t/op/tie.t | 95 |
1 files changed, 95 insertions, 0 deletions
diff --git a/t/op/tie.t b/t/op/tie.t index bd3f2e50f7..5db6cfb859 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -790,3 +790,98 @@ my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; print "x=$x c=$c\n"; EXPECT x=0 c=4 +######## +# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref +sub TIESCALAR { bless {}, __PACKAGE__ }; +sub STORE {}; +sub FETCH { + print "fetching... "; # make sure FETCH is called once per op + 123456 +}; +my $foo; +tie $foo, __PACKAGE__; +my $a = [1234567]; +$foo = $a; +print "+ ", 0 + $foo, "\n"; +print "** ", $foo**1, "\n"; +print "* ", $foo*1, "\n"; +print "/ ", $foo*1, "\n"; +print "% ", $foo%123457, "\n"; +print "- ", $foo-0, "\n"; +print "neg ", - -$foo, "\n"; +print "int ", int $foo, "\n"; +print "abs ", abs $foo, "\n"; +print "== ", 123456 == $foo, "\n"; +print "< ", 123455 < $foo, "\n"; +print "> ", 123457 > $foo, "\n"; +print "<= ", 123456 <= $foo, "\n"; +print ">= ", 123456 >= $foo, "\n"; +print "!= ", 0 != $foo, "\n"; +print "<=> ", 123457 <=> $foo, "\n"; +EXPECT +fetching... + 123456 +fetching... ** 123456 +fetching... * 123456 +fetching... / 123456 +fetching... % 123456 +fetching... - 123456 +fetching... neg 123456 +fetching... int 123456 +fetching... abs 123456 +fetching... == 1 +fetching... < 1 +fetching... > 1 +fetching... <= 1 +fetching... >= 1 +fetching... != 1 +fetching... <=> 1 +######## +# Ties returning overloaded objects +{ + package overloaded; + use overload + map { + my $op = $_; + $_ => sub { print "$op"; 100 } + } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> > +} +$o = bless [], overloaded; + +sub TIESCALAR { bless {}, "" } +sub FETCH { print "fetching... "; $o } +sub STORE{} +tie $ghew, ""; + +$ghew=undef; 1+$ghew; print "\n"; +$ghew=undef; $ghew**1; print "\n"; +$ghew=undef; $ghew*1; print "\n"; +$ghew=undef; $ghew/1; print "\n"; +$ghew=undef; $ghew%1; print "\n"; +$ghew=undef; $ghew-1; print "\n"; +$ghew=undef; -$ghew; print "\n"; +$ghew=undef; int $ghew; print "\n"; +$ghew=undef; abs $ghew; print "\n"; +$ghew=undef; 1 == $ghew; print "\n"; +$ghew=undef; $ghew<1; print "\n"; +$ghew=undef; $ghew>1; print "\n"; +$ghew=undef; $ghew<=1; print "\n"; +$ghew=undef; $ghew >=1; print "\n"; +$ghew=undef; $ghew != 1; print "\n"; +$ghew=undef; $ghew<=>1; print "\n"; +EXPECT +fetching... + +fetching... ** +fetching... * +fetching... / +fetching... % +fetching... - +fetching... neg +fetching... int +fetching... abs +fetching... == +fetching... < +fetching... > +fetching... <= +fetching... >= +fetching... != +fetching... <=> |