dist/B-Deparse/t/deparse.t

   1 #!./perl
   2
   3 BEGIN {
   4     unshift @INC, 't';
   5     require Config;
   6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   7         print "1..0 # Skip -- Perl configured without B module\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use warnings;
  13 use strict;
  14 BEGIN {
  15     # BEGIN block is acutally a subroutine :-)
  16     return unless $] > 5.009;
  17     require feature;
  18     feature->import(':5.10');
  19 }
  20 use Test::More tests => 89;
  21 use Config ();
  22
  23 use B::Deparse;
  24 my $deparse = B::Deparse->new();
  25 ok($deparse);
  26
  27 # Tell B::Deparse about our ambient pragmas
  28 { my ($hint_bits, $warning_bits, $hinthash);
  29  BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
  30  $deparse->ambient_pragmas (
  31      hint_bits    => $hint_bits,
  32      warning_bits => $warning_bits,
  33      '$['         => 0 + $[,
  34      '%^H'        => $hinthash,
  35  );
  36 }
  37
  38 $/ = "\n####\n";
  39 while (<DATA>) {
  40     chomp;
  41     # This code is pinched from the t/lib/common.pl for TODO.
  42     # It's not clear how to avoid duplication
  43     # Now tweaked a bit to do skip or todo
  44     my %reason;
  45     foreach my $what (qw(skip todo)) {
  46         s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
  47         # If the SKIP reason starts ? then it's taken as a code snippet to
  48         # evaluate. This provides the flexibility to have conditional SKIPs
  49         if ($reason{$what} && $reason{$what} =~ s/^\?//) {
  50             my $temp = eval $reason{$what};
  51             if ($@) {
  52                 die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
  53             }
  54             $reason{$what} = $temp;
  55         }
  56     }
  57
  58     s/^\s*#\s*(.*)$//mg;
  59     my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
  60
  61     if ($reason{skip}) {
  62         # Like this to avoid needing a label SKIP:
  63        Test::More->builder->skip($reason{skip});
  64         next;
  65     }
  66
  67     my ($input, $expected);
  68     if (/(.*)\n>>>>\n(.*)/s) {
  69         ($input, $expected) = ($1, $2);
  70     }
  71     else {
  72         ($input, $expected) = ($_, $_);
  73     }
  74
  75     my $coderef = eval "sub {$input}";
  76
  77     if ($@) {
  78         diag("$num deparsed: $@");
  79         ok(0, $testname);
  80     }
  81     else {
  82         my $deparsed = $deparse->coderef2text( $coderef );
  83         my $regex = $expected;
  84         $regex =~ s/(\S+)/\Q$1/g;
  85         $regex =~ s/\s+/\\s+/g;
  86         $regex = '^\{\s*' . $regex . '\s*\}$';
  87
  88         local $::TODO = $reason{todo};
  89         like($deparsed, qr/$regex/, $testname);
  90     }
  91 }
  92
  93 use constant 'c', 'stuff';
  94 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
  95
  96 my $a = 0;
  97 is("{\n    (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
  98
  99 use constant cr => ['hello'];
 100 my $string = "sub " . $deparse->coderef2text(\&cr);
 101 my $val = (eval $string)->() or diag $string;
 102 is(ref($val), 'ARRAY');
 103 is($val->[0], 'hello');
 104
 105 my $path = join " ", map { qq["-I$_"] } @INC;
 106
 107 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
 108 $a =~ s/-e syntax OK\n//g;
 109 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 110 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 111 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 112 $b = <<'EOF';
 113 BEGIN { $^I = ".bak"; }
 114 BEGIN { $^W = 1; }
 115 BEGIN { $/ = "\n"; $\ = "\n"; }
 116 LINE: while (defined($_ = <ARGV>)) {
 117     chomp $_;
 118     our(@F) = split(' ', $_, 0);
 119     '???';
 120 }
 121 EOF
 122 is($a, $b);
 123
 124 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
 125 $a =~ s/-e syntax OK\n//g;
 126 is($a, "use constant ('PI', 4);\n",
 127    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
 128
 129 #Re: perlbug #35857, patch #24505
 130 #handle warnings::register-ed packages properly.
 131 package B::Deparse::Wrapper;
 132 use strict;
 133 use warnings;
 134 use warnings::register;
 135 sub getcode {
 136    my $deparser = B::Deparse->new();
 137    return $deparser->coderef2text(shift);
 138 }
 139
 140 package Moo;
 141 use overload '0+' => sub { 42 };
 142
 143 package main;
 144 use strict;
 145 use warnings;
 146 use constant GLIPP => 'glipp';
 147 use constant PI => 4;
 148 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
 149 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
 150 BEGIN { delete $::Fcntl::{O_APPEND}; }
 151 use POSIX qw/O_CREAT/;
 152 sub test {
 153    my $val = shift;
 154    my $res = B::Deparse::Wrapper::getcode($val);
 155    like( $res, qr/use warnings/);
 156 }
 157 my ($q,$p);
 158 my $x=sub { ++$q,++$p };
 159 test($x);
 160 eval <<EOFCODE and test($x);
 161    package bar;
 162    use strict;
 163    use warnings;
 164    use warnings::register;
 165    package main;
 166    1
 167 EOFCODE
 168
 169 __DATA__
 170 # 2
 171 1;
 172 ####
 173 # 3
 174 {
 175     no warnings;
 176     '???';
 177     2;
 178 }
 179 ####
 180 # 4
 181 my $test;
 182 ++$test and $test /= 2;
 183 >>>>
 184 my $test;
 185 $test /= 2 if ++$test;
 186 ####
 187 # 5
 188 -((1, 2) x 2);
 189 ####
 190 # 6
 191 {
 192     my $test = sub : lvalue {
 193         my $x;
 194     }
 195     ;
 196 }
 197 ####
 198 # 7
 199 {
 200     my $test = sub : method {
 201         my $x;
 202     }
 203     ;
 204 }
 205 ####
 206 # 8
 207 # Was sub : locked method { ... }
 208 # This number could be re-used.
 209 ####
 210 # 9
 211 {
 212     234;
 213 }
 214 continue {
 215     123;
 216 }
 217 ####
 218 # 10
 219 my $x;
 220 print $main::x;
 221 ####
 222 # 11
 223 my @x;
 224 print $main::x[1];
 225 ####
 226 # 12
 227 my %x;
 228 $x{warn()};
 229 ####
 230 # 13
 231 my $foo;
 232 $_ .= <ARGV> . <$foo>;
 233 ####
 234 # 14
 235 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 236 ####
 237 # 15
 238 s/x/'y';/e;
 239 ####
 240 # 16 - various lypes of loop
 241 { my $x; }
 242 ####
 243 # 17
 244 while (1) { my $k; }
 245 ####
 246 # 18
 247 my ($x,@a);
 248 $x=1 for @a;
 249 >>>>
 250 my($x, @a);
 251 $x = 1 foreach (@a);
 252 ####
 253 # 19
 254 for (my $i = 0; $i < 2;) {
 255     my $z = 1;
 256 }
 257 ####
 258 # 20
 259 for (my $i = 0; $i < 2; ++$i) {
 260     my $z = 1;
 261 }
 262 ####
 263 # 21
 264 for (my $i = 0; $i < 2; ++$i) {
 265     my $z = 1;
 266 }
 267 ####
 268 # 22
 269 my $i;
 270 while ($i) { my $z = 1; } continue { $i = 99; }
 271 ####
 272 # 23
 273 foreach my $i (1, 2) {
 274     my $z = 1;
 275 }
 276 ####
 277 # 24
 278 my $i;
 279 foreach $i (1, 2) {
 280     my $z = 1;
 281 }
 282 ####
 283 # 25
 284 my $i;
 285 foreach my $i (1, 2) {
 286     my $z = 1;
 287 }
 288 ####
 289 # 26
 290 foreach my $i (1, 2) {
 291     my $z = 1;
 292 }
 293 ####
 294 # 27
 295 foreach our $i (1, 2) {
 296     my $z = 1;
 297 }
 298 ####
 299 # 28
 300 my $i;
 301 foreach our $i (1, 2) {
 302     my $z = 1;
 303 }
 304 ####
 305 # 29
 306 my @x;
 307 print reverse sort(@x);
 308 ####
 309 # 30
 310 my @x;
 311 print((sort {$b cmp $a} @x));
 312 ####
 313 # 31
 314 my @x;
 315 print((reverse sort {$b <=> $a} @x));
 316 ####
 317 # 32
 318 our @a;
 319 print $_ foreach (reverse @a);
 320 ####
 321 # 33
 322 our @a;
 323 print $_ foreach (reverse 1, 2..5);
 324 ####
 325 # 34  (bug #38684)
 326 our @ary;
 327 @ary = split(' ', 'foo', 0);
 328 ####
 329 # 35 (bug #40055)
 330 do { () };
 331 ####
 332 # 36 (ibid.)
 333 do { my $x = 1; $x };
 334 ####
 335 # 37 <20061012113037.GJ25805@c4.convolution.nl>
 336 my $f = sub {
 337     +{[]};
 338 } ;
 339 ####
 340 # 38 (bug #43010)
 341 '!@$%'->();
 342 ####
 343 # 39 (ibid.)
 344 ::();
 345 ####
 346 # 40 (ibid.)
 347 '::::'->();
 348 ####
 349 # 41 (ibid.)
 350 &::::;
 351 ####
 352 # 42
 353 my $bar;
 354 'Foo'->$bar('orz');
 355 ####
 356 # 43
 357 'Foo'->bar('orz');
 358 ####
 359 # 44
 360 'Foo'->bar;
 361 ####
 362 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 363 # 45 say
 364 say 'foo';
 365 ####
 366 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 367 # 46 state vars
 368 state $x = 42;
 369 ####
 370 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 371 # 47 state var assignment
 372 {
 373     my $y = (state $x = 42);
 374 }
 375 ####
 376 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 377 # 48 state vars in anoymous subroutines
 378 $a = sub {
 379     state $x;
 380     return $x++;
 381 }
 382 ;
 383 ####
 384 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 385 # 49 each @array;
 386 each @ARGV;
 387 each @$a;
 388 ####
 389 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 390 # 50 keys @array; values @array
 391 keys @$a if keys @ARGV;
 392 values @ARGV if values @$a;
 393 ####
 394 # 51 Anonymous arrays and hashes, and references to them
 395 my $a = {};
 396 my $b = \{};
 397 my $c = [];
 398 my $d = \[];
 399 ####
 400 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 401 # 52 implicit smartmatch in given/when
 402 given ('foo') {
 403     when ('bar') { continue; }
 404     when ($_ ~~ 'quux') { continue; }
 405     default { 0; }
 406 }
 407 ####
 408 # 53 conditions in elsifs (regression in change #33710 which fixed bug #37302)
 409 if ($a) { x(); }
 410 elsif ($b) { x(); }
 411 elsif ($a and $b) { x(); }
 412 elsif ($a or $b) { x(); }
 413 else { x(); }
 414 ####
 415 # 54 interpolation in regexps
 416 my($y, $t);
 417 /x${y}z$t/;
 418 ####
 419 # TODO new undocumented cpan-bug #33708
 420 # 55  (cpan-bug #33708)
 421 %{$_ || {}}
 422 ####
 423 # TODO hash constants not yet fixed
 424 # 56  (cpan-bug #33708)
 425 use constant H => { "#" => 1 }; H->{"#"}
 426 ####
 427 # TODO optimized away 0 not yet fixed
 428 # 57  (cpan-bug #33708)
 429 foreach my $i (@_) { 0 }
 430 ####
 431 # 58 tests with not, not optimized
 432 my $c;
 433 x() unless $a;
 434 x() if not $a and $b;
 435 x() if $a and not $b;
 436 x() unless not $a and $b;
 437 x() unless $a and not $b;
 438 x() if not $a or $b;
 439 x() if $a or not $b;
 440 x() unless not $a or $b;
 441 x() unless $a or not $b;
 442 x() if $a and not $b and $c;
 443 x() if not $a and $b and not $c;
 444 x() unless $a and not $b and $c;
 445 x() unless not $a and $b and not $c;
 446 x() if $a or not $b or $c;
 447 x() if not $a or $b or not $c;
 448 x() unless $a or not $b or $c;
 449 x() unless not $a or $b or not $c;
 450 ####
 451 # 59 tests with not, optimized
 452 my $c;
 453 x() if not $a;
 454 x() unless not $a;
 455 x() if not $a and not $b;
 456 x() unless not $a and not $b;
 457 x() if not $a or not $b;
 458 x() unless not $a or not $b;
 459 x() if not $a and not $b and $c;
 460 x() unless not $a and not $b and $c;
 461 x() if not $a or not $b or $c;
 462 x() unless not $a or not $b or $c;
 463 x() if not $a and not $b and not $c;
 464 x() unless not $a and not $b and not $c;
 465 x() if not $a or not $b or not $c;
 466 x() unless not $a or not $b or not $c;
 467 x() unless not $a or not $b or not $c;
 468 >>>>
 469 my $c;
 470 x() unless $a;
 471 x() if $a;
 472 x() unless $a or $b;
 473 x() if $a or $b;
 474 x() unless $a and $b;
 475 x() if $a and $b;
 476 x() if not $a || $b and $c;
 477 x() unless not $a || $b and $c;
 478 x() if not $a && $b or $c;
 479 x() unless not $a && $b or $c;
 480 x() unless $a or $b or $c;
 481 x() if $a or $b or $c;
 482 x() unless $a and $b and $c;
 483 x() if $a and $b and $c;
 484 x() unless not $a && $b && $c;
 485 ####
 486 # 60 tests that should be constant folded
 487 x() if 1;
 488 x() if GLIPP;
 489 x() if !GLIPP;
 490 x() if GLIPP && GLIPP;
 491 x() if !GLIPP || GLIPP;
 492 x() if do { GLIPP };
 493 x() if do { no warnings 'void'; 5; GLIPP };
 494 x() if do { !GLIPP };
 495 if (GLIPP) { x() } else { z() }
 496 if (!GLIPP) { x() } else { z() }
 497 if (GLIPP) { x() } elsif (GLIPP) { z() }
 498 if (!GLIPP) { x() } elsif (GLIPP) { z() }
 499 if (GLIPP) { x() } elsif (!GLIPP) { z() }
 500 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
 501 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
 502 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 503 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 504 >>>>
 505 x();
 506 x();
 507 '???';
 508 x();
 509 x();
 510 x();
 511 x();
 512 do {
 513     '???'
 514 };
 515 do {
 516     x()
 517 };
 518 do {
 519     z()
 520 };
 521 do {
 522     x()
 523 };
 524 do {
 525     z()
 526 };
 527 do {
 528     x()
 529 };
 530 '???';
 531 do {
 532     t()
 533 };
 534 '???';
 535 !1;
 536 ####
 537 # TODO constant deparsing has been backed out for 5.12
 538 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 539 # 61 tests that shouldn't be constant folded
 540 # It might be fundamentally impossible to make this work on ithreads, in which
 541 # case the TODO should become a SKIP
 542 x() if $a;
 543 if ($a == 1) { x() } elsif ($b == 2) { z() }
 544 if (do { foo(); GLIPP }) { x() }
 545 if (do { $a++; GLIPP }) { x() }
 546 >>>>
 547 x() if $a;
 548 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
 549 if (do { foo(); GLIPP }) { x(); }
 550 if (do { ++$a; GLIPP }) { x(); }
 551 ####
 552 # TODO constant deparsing has been backed out for 5.12
 553 # 62 tests for deparsing constants
 554 warn PI;
 555 ####
 556 # TODO constant deparsing has been backed out for 5.12
 557 # 63 tests for deparsing imported constants
 558 warn O_TRUNC;
 559 ####
 560 # TODO constant deparsing has been backed out for 5.12
 561 # 64 tests for deparsing re-exported constants
 562 warn O_CREAT;
 563 ####
 564 # TODO constant deparsing has been backed out for 5.12
 565 # 65 tests for deparsing imported constants that got deleted from the original namespace
 566 warn O_APPEND;
 567 ####
 568 # TODO constant deparsing has been backed out for 5.12
 569 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 570 # 66 tests for deparsing constants which got turned into full typeglobs
 571 # It might be fundamentally impossible to make this work on ithreads, in which
 572 # case the TODO should become a SKIP
 573 warn O_EXCL;
 574 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
 575 warn O_EXCL;
 576 ####
 577 # TODO constant deparsing has been backed out for 5.12
 578 # 67 tests for deparsing of blessed constant with overloaded numification
 579 warn OVERLOADED_NUMIFICATION;
 580 ####
 581 # TODO Only strict 'refs' currently supported
 582 # 68 strict
 583 no strict;
 584 $x;
 585 ####
 586 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
 587 no warnings 'deprecated';
 588 my $x;
 589 ####
 590 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
 591 use strict;
 592 no warnings;
 593
 594 foreach (0..3) {
 595     my $x = 2;
 596     {
 597         my $x if 0;
 598         print ++$x, "\n";
 599     }
 600 }
 601 ####
 602 my $pi = 4;
 603 ####
 604 no warnings;
 605 my $pi := 4;
 606 >>>>
 607 no warnings;
 608 my $pi = 4;
 609 ####
 610 my $pi : = 4;
 611 >>>>
 612 my $pi = 4;
 613 ####
 614 our @a;
 615 my @b;
 616 @a = sort @a;
 617 @b = sort @b;
 618 ();
 619 ####
 620 our @a;
 621 my @b;
 622 @a = reverse @a;
 623 @b = reverse @b;
 624 ();
 625 ####
 626 my($r, $s, @a);
 627 @a = split(/foo/, $s, 0);
 628 $r = qr/foo/;
 629 @a = split(/$r/, $s, 0);
 630 ();
 631 ####
 632 {
 633     package Foo;
 634     label: print 123;
 635 }
 636 ####
 637 shift;
 638 >>>>
 639 shift();
 640 ####
 641 shift @_;
 642 ####
 643 pop;
 644 >>>>
 645 pop();
 646 ####
 647 pop @_;