lib/overload64.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require Config;
   7     if ($Config::Config{'uvsize'} != 8) {
   8         print "1..0 # Skip -- Perl configured with 32-bit ints\n";
   9         exit 0;
  10     }
  11 }
  12
  13 $| = 1;
  14 use Test::More 'tests' => 100;
  15
  16
  17 my $ii = 36028797018963971;  # 2^55 + 3
  18
  19
  20 ### Tests with numerifying large positive int
  21 { package Oobj;
  22     use overload '0+' => sub { ${$_[0]} += 1; $ii },
  23                  'fallback' => 1;
  24 }
  25 my $oo = bless(\do{my $x = 0}, 'Oobj');
  26 my $cnt = 1;
  27
  28 is("$oo", "$ii", '0+ overload with stringification');
  29 is($$oo, $cnt++, 'overload called once');
  30
  31 is($oo>>3, $ii>>3, '0+ overload with bit shift right');
  32 is($$oo, $cnt++, 'overload called once');
  33
  34 is($oo<<2, $ii<<2, '0+ overload with bit shift left');
  35 is($$oo, $cnt++, 'overload called once');
  36
  37 is($oo|0xFF00, $ii|0xFF00, '0+ overload with bitwise or');
  38 is($$oo, $cnt++, 'overload called once');
  39
  40 is($oo&0xFF03, $ii&0xFF03, '0+ overload with bitwise and');
  41 is($$oo, $cnt++, 'overload called once');
  42
  43 ok($oo == $ii, '0+ overload with equality');
  44 is($$oo, $cnt++, 'overload called once');
  45
  46 is(int($oo), $ii, '0+ overload with int()');
  47 is($$oo, $cnt++, 'overload called once');
  48
  49 is(abs($oo), $ii, '0+ overload with abs()');
  50 is($$oo, $cnt++, 'overload called once');
  51
  52 is(-$oo, -$ii, '0+ overload with unary minus');
  53 is($$oo, $cnt++, 'overload called once');
  54
  55 is(0+$oo, $ii, '0+ overload with addition');
  56 is($$oo, $cnt++, 'overload called once');
  57 is($oo+0, $ii, '0+ overload with addition');
  58 is($$oo, $cnt++, 'overload called once');
  59 is($oo+$oo, 2*$ii, '0+ overload with addition');
  60 $cnt++;
  61 is($$oo, $cnt++, 'overload called once');
  62
  63 is(0-$oo, -$ii, '0+ overload with subtraction');
  64 is($$oo, $cnt++, 'overload called once');
  65 is($oo-99, $ii-99, '0+ overload with subtraction');
  66 is($$oo, $cnt++, 'overload called once');
  67
  68 is(2*$oo, 2*$ii, '0+ overload with multiplication');
  69 is($$oo, $cnt++, 'overload called once');
  70 is($oo*3, 3*$ii, '0+ overload with multiplication');
  71 is($$oo, $cnt++, 'overload called once');
  72
  73 is($oo/1, $ii, '0+ overload with division');
  74 is($$oo, $cnt++, 'overload called once');
  75 is($ii/$oo, 1, '0+ overload with division');
  76 is($$oo, $cnt++, 'overload called once');
  77
  78 is($oo%100, $ii%100, '0+ overload with modulo');
  79 is($$oo, $cnt++, 'overload called once');
  80 is($ii%$oo, 0, '0+ overload with modulo');
  81 is($$oo, $cnt++, 'overload called once');
  82
  83 is($oo**1, $ii, '0+ overload with exponentiation');
  84 is($$oo, $cnt++, 'overload called once');
  85
  86
  87 ### Tests with numerifying large negative int
  88 { package Oobj2;
  89     use overload '0+' => sub { ${$_[0]} += 1; -$ii },
  90                  'fallback' => 1;
  91 }
  92 $oo = bless(\do{my $x = 0}, 'Oobj2');
  93 $cnt = 1;
  94
  95 is(int($oo), -$ii, '0+ overload with int()');
  96 is($$oo, $cnt++, 'overload called once');
  97
  98 is(abs($oo), $ii, '0+ overload with abs()');
  99 is($$oo, $cnt++, 'overload called once');
 100
 101 is(-$oo, $ii, '0+ overload with unary -');
 102 is($$oo, $cnt++, 'overload called once');
 103
 104 is(0+$oo, -$ii, '0+ overload with addition');
 105 is($$oo, $cnt++, 'overload called once');
 106 is($oo+0, -$ii, '0+ overload with addition');
 107 is($$oo, $cnt++, 'overload called once');
 108 is($oo+$oo, -2*$ii, '0+ overload with addition');
 109 $cnt++;
 110 is($$oo, $cnt++, 'overload called once');
 111
 112 is(0-$oo, $ii, '0+ overload with subtraction');
 113 is($$oo, $cnt++, 'overload called once');
 114
 115 is(2*$oo, -2*$ii, '0+ overload with multiplication');
 116 is($$oo, $cnt++, 'overload called once');
 117 is($oo*3, -3*$ii, '0+ overload with multiplication');
 118 is($$oo, $cnt++, 'overload called once');
 119
 120 is($oo/1, -$ii, '0+ overload with division');
 121 is($$oo, $cnt++, 'overload called once');
 122 is($ii/$oo, -1, '0+ overload with division');
 123 is($$oo, $cnt++, 'overload called once');
 124
 125 is($oo%100, (-$ii)%100, '0+ overload with modulo');
 126 is($$oo, $cnt++, 'overload called once');
 127 is($ii%$oo, 0, '0+ overload with modulo');
 128 is($$oo, $cnt++, 'overload called once');
 129
 130 is($oo**1, -$ii, '0+ overload with exponentiation');
 131 is($$oo, $cnt++, 'overload called once');
 132
 133 ### Tests with overloading but no fallback
 134 { package Oobj3;
 135     use overload
 136         'int' => sub { ${$_[0]} += 1; $ii },
 137         'abs' => sub { ${$_[0]} += 1; $ii },
 138         'neg' => sub { ${$_[0]} += 1; -$ii },
 139         '+' => sub {
 140             ${$_[0]} += 1;
 141             my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
 142             $res   += (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
 143         },
 144         '-' => sub {
 145             ${$_[0]} += 1;
 146             my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
 147             my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
 148             $res   -= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
 149         },
 150         '*' => sub {
 151             ${$_[0]} += 1;
 152             my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
 153             $res   *= (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
 154         },
 155         '/' => sub {
 156             ${$_[0]} += 1;
 157             my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
 158             my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii+1 : $_[$l];
 159             $res   /= (ref($_[$r]) eq __PACKAGE__) ? $ii+1 : $_[$r];
 160         },
 161         '%' => sub {
 162             ${$_[0]} += 1;
 163             my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
 164             my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
 165             $res   %= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
 166         },
 167         '**' => sub {
 168             ${$_[0]} += 1;
 169             my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
 170             my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
 171             $res  **= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
 172         },
 173 }
 174 $oo = bless(\do{my $x = 0}, 'Oobj3');
 175 $cnt = 1;
 176
 177 is(int($oo), $ii, 'int() overload');
 178 is($$oo, $cnt++, 'overload called once');
 179
 180 is(abs($oo), $ii, 'abs() overload');
 181 is($$oo, $cnt++, 'overload called once');
 182
 183 is(-$oo, -$ii, 'neg overload');
 184 is($$oo, $cnt++, 'overload called once');
 185
 186 is(0+$oo, $ii, '+ overload');
 187 is($$oo, $cnt++, 'overload called once');
 188 is($oo+0, $ii, '+ overload');
 189 is($$oo, $cnt++, 'overload called once');
 190 is($oo+$oo, 2*$ii, '+ overload');
 191 is($$oo, $cnt++, 'overload called once');
 192
 193 is(0-$oo, -$ii, '- overload');
 194 is($$oo, $cnt++, 'overload called once');
 195 is($oo-99, $ii-99, '- overload');
 196 is($$oo, $cnt++, 'overload called once');
 197
 198 is($oo*2, 2*$ii, '* overload');
 199 is($$oo, $cnt++, 'overload called once');
 200 is(-3*$oo, -3*$ii, '* overload');
 201 is($$oo, $cnt++, 'overload called once');
 202
 203 is($oo/2, ($ii+1)/2, '/ overload');
 204 is($$oo, $cnt++, 'overload called once');
 205 is(($ii+1)/$oo, 1, '/ overload');
 206 is($$oo, $cnt++, 'overload called once');
 207
 208 is($oo%100, $ii%100, '% overload');
 209 is($$oo, $cnt++, 'overload called once');
 210 is($ii%$oo, 0, '% overload');
 211 is($$oo, $cnt++, 'overload called once');
 212
 213 is($oo**1, $ii, '** overload');
 214 is($$oo, $cnt++, 'overload called once');
 215
 216 # EOF