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 done_testing();