216 lines
6.6 KiB
Perl
216 lines
6.6 KiB
Perl
#!./perl
|
|
|
|
BEGIN {
|
|
chdir 't' if -d 't';
|
|
@INC = '../lib';
|
|
require Config;
|
|
if (%Config::Config{'uvsize'} != 8) {
|
|
print "1..0 # Skip -- Perl configured with 32-bit ints\n";
|
|
exit 0;
|
|
}
|
|
}
|
|
|
|
$| = 1;
|
|
use Test::More 'tests' => 100;
|
|
|
|
|
|
my $ii = 36028797018963971; # 2^55 + 3
|
|
|
|
|
|
### Tests with numerifying large positive int
|
|
{ package Oobj;
|
|
use overload '0+' => sub { ${@_[0]} += 1; $ii },
|
|
'fallback' => 1;
|
|
}
|
|
my $oo = bless(\do{my $x = 0}, 'Oobj');
|
|
my $cnt = 1;
|
|
|
|
is("$oo", "$ii", '0+ overload with stringification');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo>>3, $ii>>3, '0+ overload with bit shift right');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo<<2, $ii<<2, '0+ overload with bit shift left');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo^|^0xFF00, $ii^|^0xFF00, '0+ overload with bitwise or');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo^&^0xFF03, $ii^&^0xFF03, '0+ overload with bitwise and');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
ok($oo == $ii, '0+ overload with equality');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(int($oo), $ii, '0+ overload with int()');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(abs($oo), $ii, '0+ overload with abs()');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(-$oo, -$ii, '0+ overload with unary minus');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0+$oo, $ii, '0+ overload with addition');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+0, $ii, '0+ overload with addition');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+$oo, 2*$ii, '0+ overload with addition');
|
|
$cnt++;
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0-$oo, -$ii, '0+ overload with subtraction');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo-99, $ii-99, '0+ overload with subtraction');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(2*$oo, 2*$ii, '0+ overload with multiplication');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo*3, 3*$ii, '0+ overload with multiplication');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo/1, $ii, '0+ overload with division');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($ii/$oo, 1, '0+ overload with division');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo%100, $ii%100, '0+ overload with modulo');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($ii%$oo, 0, '0+ overload with modulo');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo**1, $ii, '0+ overload with exponentiation');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
|
|
### Tests with numerifying large negative int
|
|
{ package Oobj2;
|
|
use overload '0+' => sub { ${@_[0]} += 1; -$ii },
|
|
'fallback' => 1;
|
|
}
|
|
$oo = bless(\do{my $x = 0}, 'Oobj2');
|
|
$cnt = 1;
|
|
|
|
is(int($oo), -$ii, '0+ overload with int()');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(abs($oo), $ii, '0+ overload with abs()');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(-$oo, $ii, '0+ overload with unary -');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0+$oo, -$ii, '0+ overload with addition');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+0, -$ii, '0+ overload with addition');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+$oo, -2*$ii, '0+ overload with addition');
|
|
$cnt++;
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0-$oo, $ii, '0+ overload with subtraction');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(2*$oo, -2*$ii, '0+ overload with multiplication');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo*3, -3*$ii, '0+ overload with multiplication');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo/1, -$ii, '0+ overload with division');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($ii/$oo, -1, '0+ overload with division');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo%100, (-$ii)%100, '0+ overload with modulo');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($ii%$oo, 0, '0+ overload with modulo');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo**1, -$ii, '0+ overload with exponentiation');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
### Tests with overloading but no fallback
|
|
{ package Oobj3;
|
|
use overload
|
|
'int' => sub { ${@_[0]} += 1; $ii },
|
|
'abs' => sub { ${@_[0]} += 1; $ii },
|
|
'neg' => sub { ${@_[0]} += 1; -$ii },
|
|
'+' => sub {
|
|
${@_[0]} += 1;
|
|
my $res = (ref(@_[0]) eq __PACKAGE__) ? $ii : @_[0];
|
|
$res += (ref(@_[1]) eq __PACKAGE__) ? $ii : @_[1];
|
|
},
|
|
'-' => sub {
|
|
${@_[0]} += 1;
|
|
my ($l, $r) = (@_[2]) ? (1, 0) : (0, 1);
|
|
my $res = (ref(@_[$l]) eq __PACKAGE__) ? $ii : @_[$l];
|
|
$res -= (ref(@_[$r]) eq __PACKAGE__) ? $ii : @_[$r];
|
|
},
|
|
'*' => sub {
|
|
${@_[0]} += 1;
|
|
my $res = (ref(@_[0]) eq __PACKAGE__) ? $ii : @_[0];
|
|
$res *= (ref(@_[1]) eq __PACKAGE__) ? $ii : @_[1];
|
|
},
|
|
'/' => sub {
|
|
${@_[0]} += 1;
|
|
my ($l, $r) = (@_[2]) ? (1, 0) : (0, 1);
|
|
my $res = (ref(@_[$l]) eq __PACKAGE__) ? $ii+1 : @_[$l];
|
|
$res /= (ref(@_[$r]) eq __PACKAGE__) ? $ii+1 : @_[$r];
|
|
},
|
|
'%' => sub {
|
|
${@_[0]} += 1;
|
|
my ($l, $r) = (@_[2]) ? (1, 0) : (0, 1);
|
|
my $res = (ref(@_[$l]) eq __PACKAGE__) ? $ii : @_[$l];
|
|
$res %= (ref(@_[$r]) eq __PACKAGE__) ? $ii : @_[$r];
|
|
},
|
|
'**' => sub {
|
|
${@_[0]} += 1;
|
|
my ($l, $r) = (@_[2]) ? (1, 0) : (0, 1);
|
|
my $res = (ref(@_[$l]) eq __PACKAGE__) ? $ii : @_[$l];
|
|
$res **= (ref(@_[$r]) eq __PACKAGE__) ? $ii : @_[$r];
|
|
},
|
|
}
|
|
$oo = bless(\do{my $x = 0}, 'Oobj3');
|
|
$cnt = 1;
|
|
|
|
is(int($oo), $ii, 'int() overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(abs($oo), $ii, 'abs() overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(-$oo, -$ii, 'neg overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0+$oo, $ii, '+ overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+0, $ii, '+ overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo+$oo, 2*$ii, '+ overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is(0-$oo, -$ii, '- overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($oo-99, $ii-99, '- overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo*2, 2*$ii, '* overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is(-3*$oo, -3*$ii, '* overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo/2, ($ii+1)/2, '/ overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is(($ii+1)/$oo, 1, '/ overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo%100, $ii%100, '% overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
is($ii%$oo, 0, '% overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
is($oo**1, $ii, '** overload');
|
|
is($$oo, $cnt++, 'overload called once');
|
|
|
|
# EOF
|