This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2475b5ec5d802e82cb107264d46e30c0fdb77134
[perl5.git] / t / op / inc.t
1 #!./perl -w
2
3 require './test.pl';
4 use strict;
5
6 # Tests of post/pre - increment/decrement operators.
7
8 # Verify that addition/subtraction properly upgrade to doubles.
9 # These tests are only significant on machines with 32 bit longs,
10 # and two's complement negation, but shouldn't fail anywhere.
11
12 my $a = 2147483647;
13 my $c=$a++;
14 cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double");
15
16 $a = 2147483647;
17 $c=++$a;
18 cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double");
19
20 $a = 2147483647;
21 $a=$a+1;
22 cmp_ok($a, '==', 2147483648, "addition properly upgrades to double");
23
24 $a = -2147483648;
25 $c=$a--;
26 cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double");
27
28 $a = -2147483648;
29 $c=--$a;
30 cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double");
31
32 $a = -2147483648;
33 $a=$a-1;
34 cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double");
35
36 $a = 2147483648;
37 $a = -$a;
38 $c=$a--;
39 cmp_ok($a, '==', -2147483649,
40     "negation and postdecrement properly upgrade to double");
41
42 $a = 2147483648;
43 $a = -$a;
44 $c=--$a;
45 cmp_ok($a, '==', -2147483649,
46     "negation and predecrement properly upgrade to double");
47
48 $a = 2147483648;
49 $a = -$a;
50 $a=$a-1;
51 cmp_ok($a, '==', -2147483649,
52     "negation and subtraction properly upgrade to double");
53
54 $a = 2147483648;
55 $b = -$a;
56 $c=$b--;
57 cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation");
58
59 $a = 2147483648;
60 $b = -$a;
61 $c=--$b;
62 cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation");
63
64 $a = 2147483648;
65 $b = -$a;
66 $b=$b-1;
67 cmp_ok($b, '==', -(++$a),
68     "negation, subtraction, preincrement and additional negation");
69
70 $a = undef;
71 is($a++, '0', "postinc undef returns '0'");
72
73 $a = undef;
74 is($a--, undef, "postdec undef returns undef");
75
76 # Verify that shared hash keys become unshared.
77
78 sub check_same {
79   my ($orig, $suspect) = @_;
80   my $fail;
81   while (my ($key, $value) = each %$suspect) {
82     if (exists $orig->{$key}) {
83       if ($orig->{$key} ne $value) {
84         print "# key '$key' was '$orig->{$key}' now '$value'\n";
85         $fail = 1;
86       }
87     } else {
88       print "# key '$key' is '$orig->{$key}', unexpect.\n";
89       $fail = 1;
90     }
91   }
92   foreach (keys %$orig) {
93     next if (exists $suspect->{$_});
94     print "# key '$_' was '$orig->{$_}' now missing\n";
95     $fail = 1;
96   }
97   ok (!$fail, "original hashes unchanged");
98 }
99
100 my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec)
101   = (1 => 1, ab => "ab");
102 my %up = (1=>2, ab => 'ac');
103 my %down = (1=>0, ab => -1);
104
105 foreach (keys %inc) {
106   my $ans = $up{$_};
107   my $up;
108   eval {$up = ++$_};
109   is($up, $ans, "key '$_' incremented correctly");
110   is($@, '', "no error condition");
111 }
112
113 check_same (\%orig, \%inc);
114
115 foreach (keys %dec) {
116   my $ans = $down{$_};
117   my $down;
118   eval {$down = --$_};
119   is($down, $ans, "key '$_' decremented correctly");
120   is($@, '', "no error condition");
121 }
122
123 check_same (\%orig, \%dec);
124
125 foreach (keys %postinc) {
126   my $ans = $postinc{$_};
127   my $up;
128   eval {$up = $_++};
129   is($up, $ans, "assignment preceded postincrement");
130   is($@, '', "no error condition");
131 }
132
133 check_same (\%orig, \%postinc);
134
135 foreach (keys %postdec) {
136   my $ans = $postdec{$_};
137   my $down;
138   eval {$down = $_--};
139   is($down, $ans, "assignment preceded postdecrement");
140   is($@, '', "no error condition");
141 }
142
143 check_same (\%orig, \%postdec);
144
145 {
146     no warnings 'uninitialized';
147     my ($x, $y);
148     eval {
149         $y ="$x\n";
150         ++$x;
151     };
152     cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable");
153     is($@, '', "no error condition");
154
155     my ($p, $q);
156     eval {
157         $q ="$p\n";
158         --$p;
159     };
160     cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable");
161     is($@, '', "no error condition");
162 }
163
164 $a = 2147483648;
165 $c=--$a;
166 cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double");
167
168
169 $a = 2147483648;
170 $c=$a--;
171 cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
172
173 {
174     use integer;
175     my $x = 0;
176     $x++;
177     cmp_ok($x, '==', 1, "(void) i_postinc");
178     $x--;
179     cmp_ok($x, '==', 0, "(void) i_postdec");
180 }
181
182 # I'm sure that there's an IBM format with a 48 bit mantissa
183 # IEEE doubles have a 53 bit mantissa
184 # 80 bit long doubles have a 64 bit mantissa
185 # sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-)
186
187 my $h_uv_max = 1 + (~0 >> 1);
188 my $found;
189 for my $n (47..113) {
190     my $power_of_2 = 2**$n;
191     my $plus_1 = $power_of_2 + 1;
192     next if $plus_1 != $power_of_2;
193     my ($start_p, $start_n);
194     if ($h_uv_max > $power_of_2 / 2) {
195         my $uv_max = 1 + 2 * (~0 >> 1);
196         # UV_MAX is 2**$something - 1, so subtract 1 to get the start value
197         $start_p = $uv_max - 1;
198         # whereas IV_MIN is -(2**$something), so subtract 2
199         $start_n = -$h_uv_max + 2;
200         print "# Mantissa overflows at 2**$n ($power_of_2)\n";
201         print "# But max UV ($uv_max) is greater so testing that\n";
202     } else {
203         print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n";
204         $start_p = int($power_of_2 - 2);
205         $start_n = -$start_p;
206         my $check = $power_of_2 - 2;
207         die "Something wrong with our rounding assumptions: $check vs $start_p"
208             unless $start_p == $check;
209     }
210
211     foreach ([$start_p, '++$i', 'pre-inc', 'inc'],
212              [$start_p, '$i++', 'post-inc', 'inc'],
213              [$start_n, '--$i', 'pre-dec', 'dec'],
214              [$start_n, '$i--', 'post-dec', 'dec']) {
215         my ($start, $action, $description, $act) = @$_;
216         my $code = eval << "EOC" or die $@;
217 sub {
218     no warnings 'imprecision';
219     my \$i = \$start;
220     for(0 .. 3) {
221         my \$a = $action;
222     }
223 }
224 EOC
225
226         warning_is($code, undef, "$description under no warnings 'imprecision'");
227
228         $code = eval << "EOC" or die $@;
229 sub {
230     use warnings 'imprecision';
231     my \$i = \$start;
232     for(0 .. 3) {
233         my \$a = $action;
234     }
235 }
236 EOC
237
238         warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2],
239                       "$description under use warnings 'imprecision'");
240     }
241
242     $found = 1;
243     last;
244 }
245 die "Could not find a value which overflows the mantissa" unless $found;
246
247 # these will segfault if they fail
248
249 sub PVBM () { 'foo' }
250 { my $dummy = index 'foo', PVBM }
251
252 isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined");
253 isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined");
254 isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined");
255 isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined");
256
257 # #9466
258
259 # don't use pad TARG when the thing you're copying is a ref, or the referent
260 # won't get freed.
261 {
262     package P9466;
263     my $x;
264     sub DESTROY { $x = 1 }
265     for (0..1) {
266         $x = 0;
267         my $a = bless {};
268         my $b = $_ ? $a++ : $a--;
269         undef $a; undef $b;
270         ::is($x, 1, "9466 case $_");
271     }
272 }
273
274 $_ = ${qr //};
275 $_--;
276 is($_, -1, 'regexp--');
277
278 done_testing();