1#!./perl 2 3BEGIN { 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; 14use Test::More 'tests' => 140; 15 16 17my $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} 25my $oo = bless(\do{my $x = 0}, 'Oobj'); 26my $cnt = 1; 27 28is("$oo", "$ii", '0+ overload with stringification'); 29is($$oo, $cnt++, 'overload called once'); 30 31is($oo>>3, $ii>>3, '0+ overload with bit shift right'); 32is($$oo, $cnt++, 'overload called once'); 33 34is($oo<<2, $ii<<2, '0+ overload with bit shift left'); 35is($$oo, $cnt++, 'overload called once'); 36 37is($oo|0xFF00, $ii|0xFF00, '0+ overload with bitwise or'); 38is($$oo, $cnt++, 'overload called once'); 39 40is($oo&0xFF03, $ii&0xFF03, '0+ overload with bitwise and'); 41is($$oo, $cnt++, 'overload called once'); 42 43ok($oo == $ii, '0+ overload with equality'); 44is($$oo, $cnt++, 'overload called once'); 45 46is(int($oo), $ii, '0+ overload with int()'); 47is($$oo, $cnt++, 'overload called once'); 48 49is(abs($oo), $ii, '0+ overload with abs()'); 50is($$oo, $cnt++, 'overload called once'); 51 52is(-$oo, -$ii, '0+ overload with unary minus'); 53is($$oo, $cnt++, 'overload called once'); 54 55is(0+$oo, $ii, '0+ overload with addition'); 56is($$oo, $cnt++, 'overload called once'); 57is($oo+0, $ii, '0+ overload with addition'); 58is($$oo, $cnt++, 'overload called once'); 59is($oo+$oo, 2*$ii, '0+ overload with addition'); 60$cnt++; 61is($$oo, $cnt++, 'overload called once'); 62 63is(0-$oo, -$ii, '0+ overload with subtraction'); 64is($$oo, $cnt++, 'overload called once'); 65is($oo-99, $ii-99, '0+ overload with subtraction'); 66is($$oo, $cnt++, 'overload called once'); 67 68is(2*$oo, 2*$ii, '0+ overload with multiplication'); 69is($$oo, $cnt++, 'overload called once'); 70is($oo*3, 3*$ii, '0+ overload with multiplication'); 71is($$oo, $cnt++, 'overload called once'); 72 73is($oo/1, $ii, '0+ overload with division'); 74is($$oo, $cnt++, 'overload called once'); 75is($ii/$oo, 1, '0+ overload with division'); 76is($$oo, $cnt++, 'overload called once'); 77 78is($oo%100, $ii%100, '0+ overload with modulo'); 79is($$oo, $cnt++, 'overload called once'); 80is($ii%$oo, 0, '0+ overload with modulo'); 81is($$oo, $cnt++, 'overload called once'); 82 83is($oo**1, $ii, '0+ overload with exponentiation'); 84is($$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 95is(int($oo), -$ii, '0+ overload with int()'); 96is($$oo, $cnt++, 'overload called once'); 97 98is(abs($oo), $ii, '0+ overload with abs()'); 99is($$oo, $cnt++, 'overload called once'); 100 101is(-$oo, $ii, '0+ overload with unary -'); 102is($$oo, $cnt++, 'overload called once'); 103 104is(0+$oo, -$ii, '0+ overload with addition'); 105is($$oo, $cnt++, 'overload called once'); 106is($oo+0, -$ii, '0+ overload with addition'); 107is($$oo, $cnt++, 'overload called once'); 108is($oo+$oo, -2*$ii, '0+ overload with addition'); 109$cnt++; 110is($$oo, $cnt++, 'overload called once'); 111 112is(0-$oo, $ii, '0+ overload with subtraction'); 113is($$oo, $cnt++, 'overload called once'); 114 115is(2*$oo, -2*$ii, '0+ overload with multiplication'); 116is($$oo, $cnt++, 'overload called once'); 117is($oo*3, -3*$ii, '0+ overload with multiplication'); 118is($$oo, $cnt++, 'overload called once'); 119 120is($oo/1, -$ii, '0+ overload with division'); 121is($$oo, $cnt++, 'overload called once'); 122is($ii/$oo, -1, '0+ overload with division'); 123is($$oo, $cnt++, 'overload called once'); 124 125is($oo%100, (-$ii)%100, '0+ overload with modulo'); 126is($$oo, $cnt++, 'overload called once'); 127is($ii%$oo, 0, '0+ overload with modulo'); 128is($$oo, $cnt++, 'overload called once'); 129 130is($oo**1, -$ii, '0+ overload with exponentiation'); 131is($$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 177is(int($oo), $ii, 'int() overload'); 178is($$oo, $cnt++, 'overload called once'); 179 180is(abs($oo), $ii, 'abs() overload'); 181is($$oo, $cnt++, 'overload called once'); 182 183is(-$oo, -$ii, 'neg overload'); 184is($$oo, $cnt++, 'overload called once'); 185 186is(0+$oo, $ii, '+ overload'); 187is($$oo, $cnt++, 'overload called once'); 188is($oo+0, $ii, '+ overload'); 189is($$oo, $cnt++, 'overload called once'); 190is($oo+$oo, 2*$ii, '+ overload'); 191is($$oo, $cnt++, 'overload called once'); 192 193is(0-$oo, -$ii, '- overload'); 194is($$oo, $cnt++, 'overload called once'); 195is($oo-99, $ii-99, '- overload'); 196is($$oo, $cnt++, 'overload called once'); 197 198is($oo*2, 2*$ii, '* overload'); 199is($$oo, $cnt++, 'overload called once'); 200is(-3*$oo, -3*$ii, '* overload'); 201is($$oo, $cnt++, 'overload called once'); 202 203is($oo/2, ($ii+1)/2, '/ overload'); 204is($$oo, $cnt++, 'overload called once'); 205is(($ii+1)/$oo, 1, '/ overload'); 206is($$oo, $cnt++, 'overload called once'); 207 208is($oo%100, $ii%100, '% overload'); 209is($$oo, $cnt++, 'overload called once'); 210is($ii%$oo, 0, '% overload'); 211is($$oo, $cnt++, 'overload called once'); 212 213is($oo**1, $ii, '** overload'); 214is($$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 277