Update Module-CoreList Changes file for 5.20141002 release
[perl.git] / 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