Commit | Line | Data |
---|---|---|
3510b4a1 | 1 | #!./perl -w |
760ac839 | 2 | |
3ee2f9d8 JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
3ee2f9d8 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
3ee2f9d8 JH |
7 | } |
8 | ||
faa5b915 | 9 | use strict; |
760ac839 | 10 | |
3ee2f9d8 JH |
11 | use Config; |
12 | ||
fc826e38 JK |
13 | # Tests of post/pre - increment/decrement operators. |
14 | ||
760ac839 | 15 | # Verify that addition/subtraction properly upgrade to doubles. |
1eb770ff | 16 | # These tests are only significant on machines with 32 bit longs, |
17 | # and two's complement negation, but shouldn't fail anywhere. | |
760ac839 | 18 | |
3510b4a1 NC |
19 | my $a = 2147483647; |
20 | my $c=$a++; | |
fc826e38 | 21 | cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double"); |
760ac839 LW |
22 | |
23 | $a = 2147483647; | |
24 | $c=++$a; | |
fc826e38 | 25 | cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double"); |
760ac839 LW |
26 | |
27 | $a = 2147483647; | |
28 | $a=$a+1; | |
fc826e38 | 29 | cmp_ok($a, '==', 2147483648, "addition properly upgrades to double"); |
760ac839 LW |
30 | |
31 | $a = -2147483648; | |
32 | $c=$a--; | |
fc826e38 | 33 | cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double"); |
760ac839 LW |
34 | |
35 | $a = -2147483648; | |
36 | $c=--$a; | |
fc826e38 | 37 | cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double"); |
760ac839 LW |
38 | |
39 | $a = -2147483648; | |
40 | $a=$a-1; | |
fc826e38 | 41 | cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double"); |
9b0e499b GS |
42 | |
43 | $a = 2147483648; | |
44 | $a = -$a; | |
45 | $c=$a--; | |
fc826e38 JK |
46 | cmp_ok($a, '==', -2147483649, |
47 | "negation and postdecrement properly upgrade to double"); | |
9b0e499b GS |
48 | |
49 | $a = 2147483648; | |
50 | $a = -$a; | |
51 | $c=--$a; | |
fc826e38 JK |
52 | cmp_ok($a, '==', -2147483649, |
53 | "negation and predecrement properly upgrade to double"); | |
9b0e499b GS |
54 | |
55 | $a = 2147483648; | |
56 | $a = -$a; | |
57 | $a=$a-1; | |
fc826e38 JK |
58 | cmp_ok($a, '==', -2147483649, |
59 | "negation and subtraction properly upgrade to double"); | |
9b0e499b GS |
60 | |
61 | $a = 2147483648; | |
62 | $b = -$a; | |
63 | $c=$b--; | |
fc826e38 | 64 | cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation"); |
9b0e499b GS |
65 | |
66 | $a = 2147483648; | |
67 | $b = -$a; | |
68 | $c=--$b; | |
fc826e38 | 69 | cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation"); |
9b0e499b GS |
70 | |
71 | $a = 2147483648; | |
72 | $b = -$a; | |
73 | $b=$b-1; | |
fc826e38 JK |
74 | cmp_ok($b, '==', -(++$a), |
75 | "negation, subtraction, preincrement and additional negation"); | |
3510b4a1 | 76 | |
f9b9d3d6 | 77 | $a = undef; |
faa5b915 | 78 | is($a++, '0', "postinc undef returns '0'"); |
f9b9d3d6 HS |
79 | |
80 | $a = undef; | |
faa5b915 | 81 | is($a--, undef, "postdec undef returns undef"); |
f9b9d3d6 | 82 | |
3510b4a1 NC |
83 | # Verify that shared hash keys become unshared. |
84 | ||
85 | sub check_same { | |
86 | my ($orig, $suspect) = @_; | |
87 | my $fail; | |
88 | while (my ($key, $value) = each %$suspect) { | |
89 | if (exists $orig->{$key}) { | |
90 | if ($orig->{$key} ne $value) { | |
91 | print "# key '$key' was '$orig->{$key}' now '$value'\n"; | |
92 | $fail = 1; | |
93 | } | |
94 | } else { | |
95 | print "# key '$key' is '$orig->{$key}', unexpect.\n"; | |
96 | $fail = 1; | |
97 | } | |
98 | } | |
99 | foreach (keys %$orig) { | |
100 | next if (exists $suspect->{$_}); | |
101 | print "# key '$_' was '$orig->{$_}' now missing\n"; | |
102 | $fail = 1; | |
103 | } | |
fc826e38 | 104 | ok (!$fail, "original hashes unchanged"); |
3510b4a1 NC |
105 | } |
106 | ||
107 | my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) | |
108 | = (1 => 1, ab => "ab"); | |
109 | my %up = (1=>2, ab => 'ac'); | |
110 | my %down = (1=>0, ab => -1); | |
111 | ||
112 | foreach (keys %inc) { | |
113 | my $ans = $up{$_}; | |
114 | my $up; | |
115 | eval {$up = ++$_}; | |
fc826e38 JK |
116 | is($up, $ans, "key '$_' incremented correctly"); |
117 | is($@, '', "no error condition"); | |
3510b4a1 NC |
118 | } |
119 | ||
120 | check_same (\%orig, \%inc); | |
121 | ||
122 | foreach (keys %dec) { | |
123 | my $ans = $down{$_}; | |
124 | my $down; | |
125 | eval {$down = --$_}; | |
fc826e38 JK |
126 | is($down, $ans, "key '$_' decremented correctly"); |
127 | is($@, '', "no error condition"); | |
3510b4a1 NC |
128 | } |
129 | ||
130 | check_same (\%orig, \%dec); | |
131 | ||
132 | foreach (keys %postinc) { | |
133 | my $ans = $postinc{$_}; | |
134 | my $up; | |
135 | eval {$up = $_++}; | |
fc826e38 JK |
136 | is($up, $ans, "assignment preceded postincrement"); |
137 | is($@, '', "no error condition"); | |
3510b4a1 NC |
138 | } |
139 | ||
140 | check_same (\%orig, \%postinc); | |
141 | ||
142 | foreach (keys %postdec) { | |
143 | my $ans = $postdec{$_}; | |
144 | my $down; | |
145 | eval {$down = $_--}; | |
fc826e38 JK |
146 | is($down, $ans, "assignment preceded postdecrement"); |
147 | is($@, '', "no error condition"); | |
3510b4a1 NC |
148 | } |
149 | ||
150 | check_same (\%orig, \%postdec); | |
ef088171 NC |
151 | |
152 | { | |
153 | no warnings 'uninitialized'; | |
840378f5 | 154 | my ($x, $y); |
ef088171 NC |
155 | eval { |
156 | $y ="$x\n"; | |
157 | ++$x; | |
158 | }; | |
fc826e38 JK |
159 | cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable"); |
160 | is($@, '', "no error condition"); | |
ef088171 | 161 | |
840378f5 | 162 | my ($p, $q); |
ef088171 NC |
163 | eval { |
164 | $q ="$p\n"; | |
165 | --$p; | |
166 | }; | |
fc826e38 JK |
167 | cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable"); |
168 | is($@, '', "no error condition"); | |
ef088171 | 169 | } |
f4eee32f NC |
170 | |
171 | $a = 2147483648; | |
172 | $c=--$a; | |
fc826e38 | 173 | cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double"); |
f4eee32f NC |
174 | |
175 | ||
176 | $a = 2147483648; | |
177 | $c=$a--; | |
fc826e38 | 178 | cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double"); |
679d6c4e HS |
179 | |
180 | { | |
181 | use integer; | |
182 | my $x = 0; | |
183 | $x++; | |
faa5b915 | 184 | cmp_ok($x, '==', 1, "(void) i_postinc"); |
679d6c4e | 185 | $x--; |
faa5b915 | 186 | cmp_ok($x, '==', 0, "(void) i_postdec"); |
679d6c4e | 187 | } |
b88df990 | 188 | |
3ee2f9d8 JH |
189 | SKIP: { |
190 | if ($Config{uselongdouble} && | |
b52b6c40 | 191 | ($Config{d_long_double_style_ieee_doubledouble})) { |
3ee2f9d8 JH |
192 | skip "the double-double format is weird", 1; |
193 | } | |
b52b6c40 | 194 | unless ($Config{d_double_style_ieee}) { |
85272d31 | 195 | skip "the doublekind $Config{doublekind} is not IEEE", 1; |
15899733 | 196 | } |
3ee2f9d8 | 197 | |
b88df990 NC |
198 | # I'm sure that there's an IBM format with a 48 bit mantissa |
199 | # IEEE doubles have a 53 bit mantissa | |
200 | # 80 bit long doubles have a 64 bit mantissa | |
201 | # sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-) | |
202 | ||
b68c599a | 203 | my $h_uv_max = 1 + (~0 >> 1); |
b88df990 NC |
204 | my $found; |
205 | for my $n (47..113) { | |
206 | my $power_of_2 = 2**$n; | |
207 | my $plus_1 = $power_of_2 + 1; | |
208 | next if $plus_1 != $power_of_2; | |
b68c599a NC |
209 | my ($start_p, $start_n); |
210 | if ($h_uv_max > $power_of_2 / 2) { | |
211 | my $uv_max = 1 + 2 * (~0 >> 1); | |
212 | # UV_MAX is 2**$something - 1, so subtract 1 to get the start value | |
213 | $start_p = $uv_max - 1; | |
214 | # whereas IV_MIN is -(2**$something), so subtract 2 | |
215 | $start_n = -$h_uv_max + 2; | |
216 | print "# Mantissa overflows at 2**$n ($power_of_2)\n"; | |
217 | print "# But max UV ($uv_max) is greater so testing that\n"; | |
218 | } else { | |
219 | print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n"; | |
220 | $start_p = int($power_of_2 - 2); | |
221 | $start_n = -$start_p; | |
222 | my $check = $power_of_2 - 2; | |
223 | die "Something wrong with our rounding assumptions: $check vs $start_p" | |
224 | unless $start_p == $check; | |
225 | } | |
b88df990 | 226 | |
2353548e NC |
227 | foreach ([$start_p, '++$i', 'pre-inc', 'inc'], |
228 | [$start_p, '$i++', 'post-inc', 'inc'], | |
229 | [$start_n, '--$i', 'pre-dec', 'dec'], | |
230 | [$start_n, '$i--', 'post-dec', 'dec']) { | |
231 | my ($start, $action, $description, $act) = @$_; | |
faa5b915 NC |
232 | my $code = eval << "EOC" or die $@; |
233 | sub { | |
234 | no warnings 'imprecision'; | |
235 | my \$i = \$start; | |
236 | for(0 .. 3) { | |
237 | my \$a = $action; | |
238 | } | |
7db8714f | 239 | } |
7db8714f | 240 | EOC |
faa5b915 NC |
241 | |
242 | warning_is($code, undef, "$description under no warnings 'imprecision'"); | |
243 | ||
244 | $code = eval << "EOC" or die $@; | |
245 | sub { | |
246 | use warnings 'imprecision'; | |
247 | my \$i = \$start; | |
248 | for(0 .. 3) { | |
249 | my \$a = $action; | |
250 | } | |
251 | } | |
252 | EOC | |
253 | ||
254 | warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2], | |
255 | "$description under use warnings 'imprecision'"); | |
b88df990 NC |
256 | } |
257 | ||
ce122704 TK |
258 | # Verify warnings on incrementing/decrementing large values |
259 | # whose integral part will not fit in NVs. [GH #18333] | |
260 | foreach ([$start_n - 4, '$i++', 'negative large value', 'inc'], | |
a236dd37 | 261 | [$start_p + 4, '$i--', 'positive large value', 'dec']) { |
ce122704 TK |
262 | my ($start, $action, $description, $act) = @$_; |
263 | my $code = eval << "EOC" or die $@; | |
264 | sub { | |
265 | use warnings 'imprecision'; | |
266 | my \$i = \$start; | |
267 | $action; | |
268 | } | |
269 | EOC | |
270 | warning_like($code, qr/Lost precision when ${act}rementing /, | |
271 | "${act}rementing $description under use warnings 'imprecision'"); | |
272 | } | |
273 | ||
b88df990 NC |
274 | $found = 1; |
275 | last; | |
276 | } | |
8f1f21f6 JH |
277 | |
278 | ok($found, "found a NV value which overflows the mantissa"); | |
6e592b3a | 279 | |
3ee2f9d8 JH |
280 | } # SKIP |
281 | ||
6e592b3a BM |
282 | # these will segfault if they fail |
283 | ||
284 | sub PVBM () { 'foo' } | |
285 | { my $dummy = index 'foo', PVBM } | |
286 | ||
fc826e38 JK |
287 | isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined"); |
288 | isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined"); | |
289 | isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined"); | |
290 | isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined"); | |
6e592b3a | 291 | |
7dcb9b98 DM |
292 | # #9466 |
293 | ||
294 | # don't use pad TARG when the thing you're copying is a ref, or the referent | |
295 | # won't get freed. | |
296 | { | |
297 | package P9466; | |
298 | my $x; | |
299 | sub DESTROY { $x = 1 } | |
300 | for (0..1) { | |
301 | $x = 0; | |
302 | my $a = bless {}; | |
303 | my $b = $_ ? $a++ : $a--; | |
304 | undef $a; undef $b; | |
faa5b915 | 305 | ::is($x, 1, "9466 case $_"); |
7dcb9b98 DM |
306 | } |
307 | } | |
faa5b915 | 308 | |
b454703a FC |
309 | # *Do* use pad TARG if it is actually a named variable, even when the thing |
310 | # you’re copying is a ref. The fix for #9466 broke this. | |
311 | { | |
312 | package P9466_2; | |
313 | my $x; | |
314 | sub DESTROY { $x = 1 } | |
315 | for (2..3) { | |
316 | $x = 0; | |
317 | my $a = bless {}; | |
318 | my $b; | |
319 | use integer; | |
320 | if ($_ == 2) { | |
321 | $b = $a--; # sassign optimised away | |
322 | } | |
323 | else { | |
324 | $b = $a++; | |
325 | } | |
326 | ::is(ref $b, __PACKAGE__, 'i_post(in|de)c/TARGMY on ref'); | |
327 | undef $a; undef $b; | |
328 | ::is($x, 1, "9466 case $_"); | |
329 | } | |
330 | } | |
331 | ||
9bcf803b FC |
332 | $_ = ${qr //}; |
333 | $_--; | |
334 | is($_, -1, 'regexp--'); | |
3f7602fa TC |
335 | { |
336 | no warnings 'numeric'; | |
337 | $_ = ${qr //}; | |
338 | $_++; | |
339 | is($_, 1, 'regexp++'); | |
340 | } | |
376ccf8b | 341 | |
67d01233 KW |
342 | if ($::IS_EBCDIC) { |
343 | $_ = v129; | |
344 | $_++; | |
345 | isnt(ref\$_, 'VSTRING', '++ flattens vstrings'); | |
346 | } | |
347 | else { | |
348 | $_ = v97; | |
349 | $_++; | |
350 | isnt(ref\$_, 'VSTRING', '++ flattens vstrings'); | |
351 | } | |
9bcf803b | 352 | |
e87de4ab FC |
353 | sub TIESCALAR {bless\my $x} |
354 | sub STORE { ++$store::called } | |
355 | tie my $t, ""; | |
356 | { | |
357 | $t = $_++; | |
358 | $t = $_--; | |
359 | use integer; | |
360 | $t = $_++; | |
361 | $t = $_--; | |
362 | } | |
363 | is $store::called, 4, 'STORE called on "my" target'; | |
364 | ||
3baa0581 FC |
365 | { |
366 | # Temporarily broken between before 5.6.0 (b162f9ea/21f5b33c) and | |
367 | # between 5.21.5 and 5.21.6 (9e319cc4fd) | |
368 | my $x = 7; | |
369 | $x = $x++; | |
370 | is $x, 7, '$lex = $lex++'; | |
371 | $x = 7; | |
372 | # broken in b162f9ea (5.6.0); fixed in 5.21.6 | |
373 | use integer; | |
374 | $x = $x++; | |
375 | is $x, 7, '$lex = $lex++ under use integer'; | |
376 | } | |
377 | ||
cb454711 DM |
378 | { |
379 | # RT #126637 - it should refuse to modify globs | |
4e346ac6 | 380 | no warnings 'once'; |
cb454711 DM |
381 | *GLOB126637 = []; |
382 | ||
383 | eval 'my $y = ++$_ for *GLOB126637'; | |
384 | like $@, qr/Modification of a read-only value/, '++*GLOB126637'; | |
385 | eval 'my $y = --$_ for *GLOB126637'; | |
386 | like $@, qr/Modification of a read-only value/, '--*GLOB126637'; | |
387 | eval 'my $y = $_++ for *GLOB126637'; | |
388 | like $@, qr/Modification of a read-only value/, '*GLOB126637++'; | |
389 | eval 'my $y = $_-- for *GLOB126637'; | |
390 | like $@, qr/Modification of a read-only value/, '*GLOB126637--'; | |
391 | ||
392 | use integer; | |
393 | ||
394 | eval 'my $y = ++$_ for *GLOB126637'; | |
395 | like $@, qr/Modification of a read-only value/, 'use int; ++*GLOB126637'; | |
396 | eval 'my $y = --$_ for *GLOB126637'; | |
397 | like $@, qr/Modification of a read-only value/, 'use int; --*GLOB126637'; | |
398 | eval 'my $y = $_++ for *GLOB126637'; | |
399 | like $@, qr/Modification of a read-only value/, 'use int; *GLOB126637++'; | |
400 | eval 'my $y = $_-- for *GLOB126637'; | |
401 | like $@, qr/Modification of a read-only value/, 'use int; *GLOB126637--'; | |
402 | } | |
403 | ||
b589ccd0 TK |
404 | # Exercises sv_inc() incrementing UV to UV, UV to NV |
405 | SKIP: { | |
406 | $a = ~1; # assumed to be UV_MAX - 1 | |
407 | ||
408 | if ($Config{uvsize} eq '4') { | |
409 | cmp_ok(++$a, '==', 4294967295, "preincrement to UV_MAX"); | |
410 | cmp_ok(++$a, '==', 4294967296, "preincrement past UV_MAX"); | |
411 | } | |
412 | elsif ($Config{uvsize} eq '8') { | |
413 | cmp_ok(++$a, '==', 18446744073709551615, "preincrement to UV_MAX"); | |
414 | # assumed that NV can hold 2 ** 64 without rounding. | |
415 | cmp_ok(++$a, '==', 18446744073709551616, "preincrement past UV_MAX"); | |
416 | } | |
417 | else { | |
418 | skip "the uvsize $Config{uvsize} is neither 4 nor 8", 2; | |
419 | } | |
420 | } # SKIP | |
421 | ||
a236dd37 TK |
422 | # Incrementing/decrementing Inf/NaN should not trigger 'imprecision' warnings |
423 | # [GH #18333, #18388] | |
424 | # Note these tests only check for warnings; t/op/infnan.t has tests that | |
425 | # checks the result of incrementing/decrementing Inf/NaN. | |
426 | foreach my $infnan ('+Inf', '-Inf', 'NaN') { | |
427 | my $start = $infnan + 0; | |
428 | SKIP: { | |
429 | skip "NV does not have $infnan", 2 | |
430 | unless ($infnan eq 'NaN' ? $Config{d_double_has_nan} : $Config{d_double_has_inf}); | |
431 | foreach (['$i++', 'inc'], | |
432 | ['$i--', 'dec']) { | |
433 | my ($action, $act) = @$_; | |
434 | my $code = eval <<"EOC" or die $@; | |
435 | sub { | |
436 | use warnings 'imprecision'; | |
437 | my \$i = \$start; | |
438 | $action; | |
439 | } | |
440 | EOC | |
441 | warning_is($code, undef, "${act}rementing $infnan under use warnings 'imprecision'"); | |
442 | } | |
443 | } # SKIP | |
444 | } | |
445 | ||
faa5b915 | 446 | done_testing(); |