re/user_prop_race_thr.t: reduce timeout
[perl.git] / t / op / inc.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 use strict;
10
11 use Config;
12
13 # Tests of post/pre - increment/decrement operators.
14
15 # Verify that addition/subtraction properly upgrade to doubles.
16 # These tests are only significant on machines with 32 bit longs,
17 # and two's complement negation, but shouldn't fail anywhere.
18
19 my $a = 2147483647;
20 my $c=$a++;
21 cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double");
22
23 $a = 2147483647;
24 $c=++$a;
25 cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double");
26
27 $a = 2147483647;
28 $a=$a+1;
29 cmp_ok($a, '==', 2147483648, "addition properly upgrades to double");
30
31 $a = -2147483648;
32 $c=$a--;
33 cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double");
34
35 $a = -2147483648;
36 $c=--$a;
37 cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double");
38
39 $a = -2147483648;
40 $a=$a-1;
41 cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double");
42
43 $a = 2147483648;
44 $a = -$a;
45 $c=$a--;
46 cmp_ok($a, '==', -2147483649,
47     "negation and postdecrement properly upgrade to double");
48
49 $a = 2147483648;
50 $a = -$a;
51 $c=--$a;
52 cmp_ok($a, '==', -2147483649,
53     "negation and predecrement properly upgrade to double");
54
55 $a = 2147483648;
56 $a = -$a;
57 $a=$a-1;
58 cmp_ok($a, '==', -2147483649,
59     "negation and subtraction properly upgrade to double");
60
61 $a = 2147483648;
62 $b = -$a;
63 $c=$b--;
64 cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation");
65
66 $a = 2147483648;
67 $b = -$a;
68 $c=--$b;
69 cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation");
70
71 $a = 2147483648;
72 $b = -$a;
73 $b=$b-1;
74 cmp_ok($b, '==', -(++$a),
75     "negation, subtraction, preincrement and additional negation");
76
77 $a = undef;
78 is($a++, '0', "postinc undef returns '0'");
79
80 $a = undef;
81 is($a--, undef, "postdec undef returns undef");
82
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   }
104   ok (!$fail, "original hashes unchanged");
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 = ++$_};
116   is($up, $ans, "key '$_' incremented correctly");
117   is($@, '', "no error condition");
118 }
119
120 check_same (\%orig, \%inc);
121
122 foreach (keys %dec) {
123   my $ans = $down{$_};
124   my $down;
125   eval {$down = --$_};
126   is($down, $ans, "key '$_' decremented correctly");
127   is($@, '', "no error condition");
128 }
129
130 check_same (\%orig, \%dec);
131
132 foreach (keys %postinc) {
133   my $ans = $postinc{$_};
134   my $up;
135   eval {$up = $_++};
136   is($up, $ans, "assignment preceded postincrement");
137   is($@, '', "no error condition");
138 }
139
140 check_same (\%orig, \%postinc);
141
142 foreach (keys %postdec) {
143   my $ans = $postdec{$_};
144   my $down;
145   eval {$down = $_--};
146   is($down, $ans, "assignment preceded postdecrement");
147   is($@, '', "no error condition");
148 }
149
150 check_same (\%orig, \%postdec);
151
152 {
153     no warnings 'uninitialized';
154     my ($x, $y);
155     eval {
156         $y ="$x\n";
157         ++$x;
158     };
159     cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable");
160     is($@, '', "no error condition");
161
162     my ($p, $q);
163     eval {
164         $q ="$p\n";
165         --$p;
166     };
167     cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable");
168     is($@, '', "no error condition");
169 }
170
171 $a = 2147483648;
172 $c=--$a;
173 cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double");
174
175
176 $a = 2147483648;
177 $c=$a--;
178 cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
179
180 {
181     use integer;
182     my $x = 0;
183     $x++;
184     cmp_ok($x, '==', 1, "(void) i_postinc");
185     $x--;
186     cmp_ok($x, '==', 0, "(void) i_postdec");
187 }
188
189 SKIP: {
190     if ($Config{uselongdouble} &&
191         ($Config{long_double_style_ieee_doubledouble})) {
192         skip "the double-double format is weird", 1;
193     }
194     unless ($Config{double_style_ieee}) {
195         skip "the doublekind $Config{doublekind} is not IEEE", 1;
196     }
197
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
203 my $h_uv_max = 1 + (~0 >> 1);
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;
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     }
226
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) = @$_;
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     }
239 }
240 EOC
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'");
256     }
257
258     $found = 1;
259     last;
260 }
261
262 ok($found, "found a NV value which overflows the mantissa");
263
264 } # SKIP
265
266 # these will segfault if they fail
267
268 sub PVBM () { 'foo' }
269 { my $dummy = index 'foo', PVBM }
270
271 isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined");
272 isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined");
273 isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined");
274 isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined");
275
276 # #9466
277
278 # don't use pad TARG when the thing you're copying is a ref, or the referent
279 # won't get freed.
280 {
281     package P9466;
282     my $x;
283     sub DESTROY { $x = 1 }
284     for (0..1) {
285         $x = 0;
286         my $a = bless {};
287         my $b = $_ ? $a++ : $a--;
288         undef $a; undef $b;
289         ::is($x, 1, "9466 case $_");
290     }
291 }
292
293 # *Do* use pad TARG if it is actually a named variable, even when the thing
294 # you’re copying is a ref.  The fix for #9466 broke this.
295 {
296     package P9466_2;
297     my $x;
298     sub DESTROY { $x = 1 }
299     for (2..3) {
300         $x = 0;
301         my $a = bless {};
302         my $b;
303         use integer;
304         if ($_ == 2) {
305             $b = $a--; # sassign optimised away
306         }
307         else {
308             $b = $a++;
309         }
310         ::is(ref $b, __PACKAGE__, 'i_post(in|de)c/TARGMY on ref');
311         undef $a; undef $b;
312         ::is($x, 1, "9466 case $_");
313     }
314 }
315
316 $_ = ${qr //};
317 $_--;
318 is($_, -1, 'regexp--');
319 {
320     no warnings 'numeric';
321     $_ = ${qr //};
322     $_++;
323     is($_, 1, 'regexp++');
324 }
325
326 if ($::IS_EBCDIC) {
327     $_ = v129;
328     $_++;
329     isnt(ref\$_, 'VSTRING', '++ flattens vstrings');
330 }
331 else {
332     $_ = v97;
333     $_++;
334     isnt(ref\$_, 'VSTRING', '++ flattens vstrings');
335 }
336
337 sub TIESCALAR {bless\my $x}
338 sub STORE { ++$store::called }
339 tie my $t, "";
340 {
341     $t = $_++;
342     $t = $_--;
343     use integer;
344     $t = $_++;
345     $t = $_--;
346 }
347 is $store::called, 4, 'STORE called on "my" target';
348
349 {
350     # Temporarily broken between before 5.6.0 (b162f9ea/21f5b33c) and
351     # between 5.21.5 and 5.21.6 (9e319cc4fd)
352     my $x = 7;
353     $x = $x++;
354     is $x, 7, '$lex = $lex++';
355     $x = 7;
356     # broken in b162f9ea (5.6.0); fixed in 5.21.6
357     use integer;
358     $x = $x++;
359     is $x, 7, '$lex = $lex++ under use integer';
360 }
361
362 {
363     # RT #126637 - it should refuse to modify globs
364     no warnings 'once';
365     *GLOB126637 = [];
366
367     eval 'my $y = ++$_ for *GLOB126637';
368     like $@, qr/Modification of a read-only value/, '++*GLOB126637';
369     eval 'my $y = --$_ for *GLOB126637';
370     like $@, qr/Modification of a read-only value/, '--*GLOB126637';
371     eval 'my $y = $_++ for *GLOB126637';
372     like $@, qr/Modification of a read-only value/, '*GLOB126637++';
373     eval 'my $y = $_-- for *GLOB126637';
374     like $@, qr/Modification of a read-only value/, '*GLOB126637--';
375
376     use integer;
377
378     eval 'my $y = ++$_ for *GLOB126637';
379     like $@, qr/Modification of a read-only value/, 'use int; ++*GLOB126637';
380     eval 'my $y = --$_ for *GLOB126637';
381     like $@, qr/Modification of a read-only value/, 'use int; --*GLOB126637';
382     eval 'my $y = $_++ for *GLOB126637';
383     like $@, qr/Modification of a read-only value/, 'use int; *GLOB126637++';
384     eval 'my $y = $_-- for *GLOB126637';
385     like $@, qr/Modification of a read-only value/, 'use int; *GLOB126637--';
386 }
387
388 done_testing();