https://perl5.git.perl.org / perl5.git / blame
| Commit | Line | Data |
|---|---|---|
| 800401ee JH |
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; | |
| a42d0242 | 14 | use Test::More 'tests' => 140; |
| 800401ee JH |
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 | ||
| a42d0242 DM |
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 | ||
| 800401ee | 276 | # EOF |