t/op/inc.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   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{longdblkind} == 6 || $Config{longdblkind} == 5)) {
 192         skip "the double-double format is weird", 1;
 193     }
 194
 195 # I'm sure that there's an IBM format with a 48 bit mantissa
 196 # IEEE doubles have a 53 bit mantissa
 197 # 80 bit long doubles have a 64 bit mantissa
 198 # sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-)
 199
 200 my $h_uv_max = 1 + (~0 >> 1);
 201 my $found;
 202 for my $n (47..113) {
 203     my $power_of_2 = 2**$n;
 204     my $plus_1 = $power_of_2 + 1;
 205     next if $plus_1 != $power_of_2;
 206     my ($start_p, $start_n);
 207     if ($h_uv_max > $power_of_2 / 2) {
 208         my $uv_max = 1 + 2 * (~0 >> 1);
 209         # UV_MAX is 2**$something - 1, so subtract 1 to get the start value
 210         $start_p = $uv_max - 1;
 211         # whereas IV_MIN is -(2**$something), so subtract 2
 212         $start_n = -$h_uv_max + 2;
 213         print "# Mantissa overflows at 2**$n ($power_of_2)\n";
 214         print "# But max UV ($uv_max) is greater so testing that\n";
 215     } else {
 216         print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n";
 217         $start_p = int($power_of_2 - 2);
 218         $start_n = -$start_p;
 219         my $check = $power_of_2 - 2;
 220         die "Something wrong with our rounding assumptions: $check vs $start_p"
 221             unless $start_p == $check;
 222     }
 223
 224     foreach ([$start_p, '++$i', 'pre-inc', 'inc'],
 225              [$start_p, '$i++', 'post-inc', 'inc'],
 226              [$start_n, '--$i', 'pre-dec', 'dec'],
 227              [$start_n, '$i--', 'post-dec', 'dec']) {
 228         my ($start, $action, $description, $act) = @$_;
 229         my $code = eval << "EOC" or die $@;
 230 sub {
 231     no warnings 'imprecision';
 232     my \$i = \$start;
 233     for(0 .. 3) {
 234         my \$a = $action;
 235     }
 236 }
 237 EOC
 238
 239         warning_is($code, undef, "$description under no warnings 'imprecision'");
 240
 241         $code = eval << "EOC" or die $@;
 242 sub {
 243     use warnings 'imprecision';
 244     my \$i = \$start;
 245     for(0 .. 3) {
 246         my \$a = $action;
 247     }
 248 }
 249 EOC
 250
 251         warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2],
 252                       "$description under use warnings 'imprecision'");
 253     }
 254
 255     $found = 1;
 256     last;
 257 }
 258
 259 ok($found, "found a NV value which overflows the mantissa");
 260
 261 } # SKIP
 262
 263 # these will segfault if they fail
 264
 265 sub PVBM () { 'foo' }
 266 { my $dummy = index 'foo', PVBM }
 267
 268 isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined");
 269 isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined");
 270 isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined");
 271 isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined");
 272
 273 # #9466
 274
 275 # don't use pad TARG when the thing you're copying is a ref, or the referent
 276 # won't get freed.
 277 {
 278     package P9466;
 279     my $x;
 280     sub DESTROY { $x = 1 }
 281     for (0..1) {
 282         $x = 0;
 283         my $a = bless {};
 284         my $b = $_ ? $a++ : $a--;
 285         undef $a; undef $b;
 286         ::is($x, 1, "9466 case $_");
 287     }
 288 }
 289
 290 # *Do* use pad TARG if it is actually a named variable, even when the thing
 291 # you’re copying is a ref.  The fix for #9466 broke this.
 292 {
 293     package P9466_2;
 294     my $x;
 295     sub DESTROY { $x = 1 }
 296     for (2..3) {
 297         $x = 0;
 298         my $a = bless {};
 299         my $b;
 300         use integer;
 301         if ($_ == 2) {
 302             $b = $a--; # sassign optimised away
 303         }
 304         else {
 305             $b = $a++;
 306         }
 307         ::is(ref $b, __PACKAGE__, 'i_post(in|de)c/TARGMY on ref');
 308         undef $a; undef $b;
 309         ::is($x, 1, "9466 case $_");
 310     }
 311 }
 312
 313 $_ = ${qr //};
 314 $_--;
 315 is($_, -1, 'regexp--');
 316 {
 317     no warnings 'numeric';
 318     $_ = ${qr //};
 319     $_++;
 320     is($_, 1, 'regexp++');
 321 }
 322
 323 if ($::IS_EBCDIC) {
 324     $_ = v129;
 325     $_++;
 326     isnt(ref\$_, 'VSTRING', '++ flattens vstrings');
 327 }
 328 else {
 329     $_ = v97;
 330     $_++;
 331     isnt(ref\$_, 'VSTRING', '++ flattens vstrings');
 332 }
 333
 334 sub TIESCALAR {bless\my $x}
 335 sub STORE { ++$store::called }
 336 tie my $t, "";
 337 {
 338     $t = $_++;
 339     $t = $_--;
 340     use integer;
 341     $t = $_++;
 342     $t = $_--;
 343 }
 344 is $store::called, 4, 'STORE called on "my" target';
 345
 346 {
 347     # Temporarily broken between before 5.6.0 (b162f9ea/21f5b33c) and
 348     # between 5.21.5 and 5.21.6 (9e319cc4fd)
 349     my $x = 7;
 350     $x = $x++;
 351     is $x, 7, '$lex = $lex++';
 352     $x = 7;
 353     # broken in b162f9ea (5.6.0); fixed in 5.21.6
 354     use integer;
 355     $x = $x++;
 356     is $x, 7, '$lex = $lex++ under use integer';
 357 }
 358
 359 done_testing();