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' => 140;
  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 # RT #77456: when conversion method returns an IV/UV,
 217 # avoid IV -> NV upgrade if possible .
 218
 219 {
 220     package P77456;
 221     use overload '0+' => sub  { $_[0][0] }, fallback => 1;
 222
 223     package main;
 224
 225     for my $expr (
 226         '(%531 + 1) - $a531  == 1',                     # pp_add
 227         '$a531 - (%531 - 1) == 1',                      # pp_subtract
 228         '(%531 * 2  + 1) - (%531 * 2)  == 1',           # pp_multiply
 229         '(%54  / 2  + 1) - (%54 / 2)   == 1',           # pp_divide
 230         '(%271 ** 2 + 1) - (%271 ** 2) == 1',           # pp_pow
 231         '(%541 % 2) == 1',                              # pp_modulo
 232         '$a54  + (-%531)*2  == -2',                     # pp_negate
 233         '(abs(%53m)+1) - $a53 == 1',                    # pp_abs
 234         '(%531 << 1) - 2  == $a54',                     # pp_left_shift
 235         '(%541 >> 1) + 1  == $a531',                    # pp_right_shift
 236         '!(%53 == %531)',                               # pp_eq
 237         '(%53 != %531)',                                # pp_ne
 238         '(%53 < %531)',                                 # pp_lt
 239         '!(%531 <= %53)',                               # pp_le
 240         '(%531 > %53)',                                 # pp_gt
 241         '!(%53 >= %531)',                               # pp_ge
 242         '(%53 <=> %531) == -1',                         # pp_ncmp
 243         '(%531 & %53) == $a53',                         # pp_bit_and
 244         '(%531 | %53) == $a531',                        # pp_bit_or
 245         '~(~ %531 + $a531) == 0',                       # pp_complement
 246     ) {
 247         for my $int ('', 'use integer; ') {
 248             (my $aexpr = "$int$expr") =~ s/\%(\d+m?)/\$a$1/g;
 249             (my $bexpr = "$int$expr") =~ s/\%(\d+m?)/\$b$1/g;
 250
 251             my $a27   = 1 << 27;
 252             my $a271  = $a27 + 1;
 253             my $a53   = 1 << 53;
 254             my $a53m  = -$a53;
 255             my $a531  = $a53 + 1;
 256             my $a54   = 1 << 54;
 257             my $a541  = $a54 + 1;
 258
 259             my $b27   = bless [ $a27   ], 'P77456';
 260             my $b271  = bless [ $a271  ], 'P77456';
 261             my $b53   = bless [ $a53   ], 'P77456';
 262             my $b53m  = bless [ $a53m  ], 'P77456';
 263             my $b531  = bless [ $a531  ], 'P77456';
 264             my $b54   = bless [ $a54   ], 'P77456';
 265             my $b541  = bless [ $a541  ], 'P77456';
 266
 267             SKIP: {
 268                 skip("IV/NV not suitable on this platform: $aexpr", 1)
 269                     unless eval $aexpr;
 270                 ok(eval $bexpr, "IV: $bexpr");
 271             }
 272         }
 273     }
 274 }
 275
 276 # EOF