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 actually a subroutine :-)
  16     return unless $] > 5.009;
  17     require feature;
  18     feature->import(':5.10');
  19 }
  20 use Test::More;
  21 use Config ();
  22
  23 use B::Deparse;
  24 my $deparse = B::Deparse->new();
  25 isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object');
  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 $desc = $1;
  60     die "Missing name in test $_" unless defined $desc;
  61
  62     if ($reason{skip}) {
  63         # Like this to avoid needing a label SKIP:
  64        Test::More->builder->skip($reason{skip});
  65         next;
  66     }
  67
  68     my ($input, $expected);
  69     if (/(.*)\n>>>>\n(.*)/s) {
  70         ($input, $expected) = ($1, $2);
  71     }
  72     else {
  73         ($input, $expected) = ($_, $_);
  74     }
  75
  76     my $coderef = eval "sub {$input}";
  77
  78     if ($@) {
  79         is($@, "", "compilation of $desc");
  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/, $desc);
  90     }
  91 }
  92
  93 use constant 'c', 'stuff';
  94 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
  95    'the subroutine generated by use constant deparses');
  96
  97 my $a = 0;
  98 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
  99    'anon sub capturing an external lexical');
 100
 101 use constant cr => ['hello'];
 102 my $string = "sub " . $deparse->coderef2text(\&cr);
 103 my $val = (eval $string)->() or diag $string;
 104 is(ref($val), 'ARRAY', 'constant array references deparse');
 105 is($val->[0], 'hello', 'and return the correct value');
 106
 107 my $path = join " ", map { qq["-I$_"] } @INC;
 108
 109 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
 110 $a =~ s/-e syntax OK\n//g;
 111 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 112 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 113 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 114 $b = <<'EOF';
 115 BEGIN { $^I = ".bak"; }
 116 BEGIN { $^W = 1; }
 117 BEGIN { $/ = "\n"; $\ = "\n"; }
 118 LINE: while (defined($_ = <ARGV>)) {
 119     chomp $_;
 120     our(@F) = split(' ', $_, 0);
 121     '???';
 122 }
 123 EOF
 124 is($a, $b,
 125    'command line flags deparse as BEGIN blocks setting control variables');
 126
 127 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
 128 $a =~ s/-e syntax OK\n//g;
 129 is($a, "use constant ('PI', 4);\n",
 130    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
 131
 132 #Re: perlbug #35857, patch #24505
 133 #handle warnings::register-ed packages properly.
 134 package B::Deparse::Wrapper;
 135 use strict;
 136 use warnings;
 137 use warnings::register;
 138 sub getcode {
 139    my $deparser = B::Deparse->new();
 140    return $deparser->coderef2text(shift);
 141 }
 142
 143 package Moo;
 144 use overload '0+' => sub { 42 };
 145
 146 package main;
 147 use strict;
 148 use warnings;
 149 use constant GLIPP => 'glipp';
 150 use constant PI => 4;
 151 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
 152 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
 153 BEGIN { delete $::Fcntl::{O_APPEND}; }
 154 use POSIX qw/O_CREAT/;
 155 sub test {
 156    my $val = shift;
 157    my $res = B::Deparse::Wrapper::getcode($val);
 158    like($res, qr/use warnings/,
 159         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
 160 }
 161 my ($q,$p);
 162 my $x=sub { ++$q,++$p };
 163 test($x);
 164 eval <<EOFCODE and test($x);
 165    package bar;
 166    use strict;
 167    use warnings;
 168    use warnings::register;
 169    package main;
 170    1
 171 EOFCODE
 172
 173 # Exotic sub declarations
 174 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
 175 $a =~ s/-e syntax OK\n//g;
 176 is($a, <<'EOCODG', "sub :::: and sub ::::::");
 177 sub :::: {
 178
 179 }
 180 sub :::::: {
 181
 182 }
 183 EOCODG
 184
 185 # [perl #33752]
 186 {
 187   my $code = <<"EOCODE";
 188 {
 189     our \$\x{1e1f}\x{14d}\x{14d};
 190 }
 191 EOCODE
 192   my $deparsed
 193    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
 194   s/$ \n//x for $deparsed, $code;
 195   is $deparsed, $code, 'our $funny_Unicode_chars';
 196 }
 197
 198 # [perl #62500]
 199 $a =
 200   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
 201 $a =~ s/-e syntax OK\n//g;
 202 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
 203 sub BEGIN {
 204     *CORE::GLOBAL::require = sub {
 205         1;
 206     }
 207     ;
 208 }
 209 EOCODF
 210
 211 done_testing();
 212
 213 __DATA__
 214 # A constant
 215 1;
 216 ####
 217 # Constants in a block
 218 {
 219     no warnings;
 220     '???';
 221     2;
 222 }
 223 ####
 224 # Lexical and simple arithmetic
 225 my $test;
 226 ++$test and $test /= 2;
 227 >>>>
 228 my $test;
 229 $test /= 2 if ++$test;
 230 ####
 231 # list x
 232 -((1, 2) x 2);
 233 ####
 234 # lvalue sub
 235 {
 236     my $test = sub : lvalue {
 237         my $x;
 238     }
 239     ;
 240 }
 241 ####
 242 # method
 243 {
 244     my $test = sub : method {
 245         my $x;
 246     }
 247     ;
 248 }
 249 ####
 250 # block with continue
 251 {
 252     234;
 253 }
 254 continue {
 255     123;
 256 }
 257 ####
 258 # lexical and package scalars
 259 my $x;
 260 print $main::x;
 261 ####
 262 # lexical and package arrays
 263 my @x;
 264 print $main::x[1];
 265 ####
 266 # lexical and package hashes
 267 my %x;
 268 $x{warn()};
 269 ####
 270 # <>
 271 my $foo;
 272 $_ .= <ARGV> . <$foo>;
 273 ####
 274 # \x{}
 275 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 276 ####
 277 # s///e
 278 s/x/'y';/e;
 279 ####
 280 # block
 281 { my $x; }
 282 ####
 283 # while 1
 284 while (1) { my $k; }
 285 ####
 286 # trailing for
 287 my ($x,@a);
 288 $x=1 for @a;
 289 >>>>
 290 my($x, @a);
 291 $x = 1 foreach (@a);
 292 ####
 293 # 2 arguments in a 3 argument for
 294 for (my $i = 0; $i < 2;) {
 295     my $z = 1;
 296 }
 297 ####
 298 # 3 argument for
 299 for (my $i = 0; $i < 2; ++$i) {
 300     my $z = 1;
 301 }
 302 ####
 303 # 3 argument for again
 304 for (my $i = 0; $i < 2; ++$i) {
 305     my $z = 1;
 306 }
 307 ####
 308 # while/continue
 309 my $i;
 310 while ($i) { my $z = 1; } continue { $i = 99; }
 311 ####
 312 # foreach with my
 313 foreach my $i (1, 2) {
 314     my $z = 1;
 315 }
 316 ####
 317 # foreach
 318 my $i;
 319 foreach $i (1, 2) {
 320     my $z = 1;
 321 }
 322 ####
 323 # foreach, 2 mys
 324 my $i;
 325 foreach my $i (1, 2) {
 326     my $z = 1;
 327 }
 328 ####
 329 # foreach
 330 foreach my $i (1, 2) {
 331     my $z = 1;
 332 }
 333 ####
 334 # foreach with our
 335 foreach our $i (1, 2) {
 336     my $z = 1;
 337 }
 338 ####
 339 # foreach with my and our
 340 my $i;
 341 foreach our $i (1, 2) {
 342     my $z = 1;
 343 }
 344 ####
 345 # reverse sort
 346 my @x;
 347 print reverse sort(@x);
 348 ####
 349 # sort with cmp
 350 my @x;
 351 print((sort {$b cmp $a} @x));
 352 ####
 353 # reverse sort with block
 354 my @x;
 355 print((reverse sort {$b <=> $a} @x));
 356 ####
 357 # foreach reverse
 358 our @a;
 359 print $_ foreach (reverse @a);
 360 ####
 361 # foreach reverse (not inplace)
 362 our @a;
 363 print $_ foreach (reverse 1, 2..5);
 364 ####
 365 # bug #38684
 366 our @ary;
 367 @ary = split(' ', 'foo', 0);
 368 ####
 369 # bug #40055
 370 do { () };
 371 ####
 372 # bug #40055
 373 do { my $x = 1; $x };
 374 ####
 375 # <20061012113037.GJ25805@c4.convolution.nl>
 376 my $f = sub {
 377     +{[]};
 378 } ;
 379 ####
 380 # bug #43010
 381 '!@$%'->();
 382 ####
 383 # bug #43010
 384 ::();
 385 ####
 386 # bug #43010
 387 '::::'->();
 388 ####
 389 # bug #43010
 390 &::::;
 391 ####
 392 # variables as method names
 393 my $bar;
 394 'Foo'->$bar('orz');
 395 ####
 396 # constants as method names
 397 'Foo'->bar('orz');
 398 ####
 399 # constants as method names without ()
 400 'Foo'->bar;
 401 ####
 402 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 403 # say
 404 say 'foo';
 405 ####
 406 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 407 # state vars
 408 state $x = 42;
 409 ####
 410 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 411 # state var assignment
 412 {
 413     my $y = (state $x = 42);
 414 }
 415 ####
 416 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 417 # state vars in anonymous subroutines
 418 $a = sub {
 419     state $x;
 420     return $x++;
 421 }
 422 ;
 423 ####
 424 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 425 # each @array;
 426 each @ARGV;
 427 each @$a;
 428 ####
 429 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 430 # keys @array; values @array
 431 keys @$a if keys @ARGV;
 432 values @ARGV if values @$a;
 433 ####
 434 # Anonymous arrays and hashes, and references to them
 435 my $a = {};
 436 my $b = \{};
 437 my $c = [];
 438 my $d = \[];
 439 ####
 440 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 441 # implicit smartmatch in given/when
 442 given ('foo') {
 443     when ('bar') { continue; }
 444     when ($_ ~~ 'quux') { continue; }
 445     default { 0; }
 446 }
 447 ####
 448 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
 449 if ($a) { x(); }
 450 elsif ($b) { x(); }
 451 elsif ($a and $b) { x(); }
 452 elsif ($a or $b) { x(); }
 453 else { x(); }
 454 ####
 455 # interpolation in regexps
 456 my($y, $t);
 457 /x${y}z$t/;
 458 ####
 459 # TODO new undocumented cpan-bug #33708
 460 # cpan-bug #33708
 461 %{$_ || {}}
 462 ####
 463 # TODO hash constants not yet fixed
 464 # cpan-bug #33708
 465 use constant H => { "#" => 1 }; H->{"#"}
 466 ####
 467 # TODO optimized away 0 not yet fixed
 468 # cpan-bug #33708
 469 foreach my $i (@_) { 0 }
 470 ####
 471 # tests with not, not optimized
 472 my $c;
 473 x() unless $a;
 474 x() if not $a and $b;
 475 x() if $a and not $b;
 476 x() unless not $a and $b;
 477 x() unless $a and not $b;
 478 x() if not $a or $b;
 479 x() if $a or not $b;
 480 x() unless not $a or $b;
 481 x() unless $a or not $b;
 482 x() if $a and not $b and $c;
 483 x() if not $a and $b and not $c;
 484 x() unless $a and not $b and $c;
 485 x() unless not $a and $b and not $c;
 486 x() if $a or not $b or $c;
 487 x() if not $a or $b or not $c;
 488 x() unless $a or not $b or $c;
 489 x() unless not $a or $b or not $c;
 490 ####
 491 # tests with not, optimized
 492 my $c;
 493 x() if not $a;
 494 x() unless not $a;
 495 x() if not $a and not $b;
 496 x() unless not $a and not $b;
 497 x() if not $a or not $b;
 498 x() unless not $a or not $b;
 499 x() if not $a and not $b and $c;
 500 x() unless not $a and not $b and $c;
 501 x() if not $a or not $b or $c;
 502 x() unless not $a or not $b or $c;
 503 x() if not $a and not $b and not $c;
 504 x() unless not $a and not $b and not $c;
 505 x() if not $a or not $b or not $c;
 506 x() unless not $a or not $b or not $c;
 507 x() unless not $a or not $b or not $c;
 508 >>>>
 509 my $c;
 510 x() unless $a;
 511 x() if $a;
 512 x() unless $a or $b;
 513 x() if $a or $b;
 514 x() unless $a and $b;
 515 x() if $a and $b;
 516 x() if not $a || $b and $c;
 517 x() unless not $a || $b and $c;
 518 x() if not $a && $b or $c;
 519 x() unless not $a && $b or $c;
 520 x() unless $a or $b or $c;
 521 x() if $a or $b or $c;
 522 x() unless $a and $b and $c;
 523 x() if $a and $b and $c;
 524 x() unless not $a && $b && $c;
 525 ####
 526 # tests that should be constant folded
 527 x() if 1;
 528 x() if GLIPP;
 529 x() if !GLIPP;
 530 x() if GLIPP && GLIPP;
 531 x() if !GLIPP || GLIPP;
 532 x() if do { GLIPP };
 533 x() if do { no warnings 'void'; 5; GLIPP };
 534 x() if do { !GLIPP };
 535 if (GLIPP) { x() } else { z() }
 536 if (!GLIPP) { x() } else { z() }
 537 if (GLIPP) { x() } elsif (GLIPP) { z() }
 538 if (!GLIPP) { x() } elsif (GLIPP) { z() }
 539 if (GLIPP) { x() } elsif (!GLIPP) { z() }
 540 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
 541 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
 542 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 543 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 544 >>>>
 545 x();
 546 x();
 547 '???';
 548 x();
 549 x();
 550 x();
 551 x();
 552 do {
 553     '???'
 554 };
 555 do {
 556     x()
 557 };
 558 do {
 559     z()
 560 };
 561 do {
 562     x()
 563 };
 564 do {
 565     z()
 566 };
 567 do {
 568     x()
 569 };
 570 '???';
 571 do {
 572     t()
 573 };
 574 '???';
 575 !1;
 576 ####
 577 # TODO constant deparsing has been backed out for 5.12
 578 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 579 # tests that shouldn't be constant folded
 580 # It might be fundamentally impossible to make this work on ithreads, in which
 581 # case the TODO should become a SKIP
 582 x() if $a;
 583 if ($a == 1) { x() } elsif ($b == 2) { z() }
 584 if (do { foo(); GLIPP }) { x() }
 585 if (do { $a++; GLIPP }) { x() }
 586 >>>>
 587 x() if $a;
 588 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
 589 if (do { foo(); GLIPP }) { x(); }
 590 if (do { ++$a; GLIPP }) { x(); }
 591 ####
 592 # TODO constant deparsing has been backed out for 5.12
 593 # tests for deparsing constants
 594 warn PI;
 595 ####
 596 # TODO constant deparsing has been backed out for 5.12
 597 # tests for deparsing imported constants
 598 warn O_TRUNC;
 599 ####
 600 # TODO constant deparsing has been backed out for 5.12
 601 # tests for deparsing re-exported constants
 602 warn O_CREAT;
 603 ####
 604 # TODO constant deparsing has been backed out for 5.12
 605 # tests for deparsing imported constants that got deleted from the original namespace
 606 warn O_APPEND;
 607 ####
 608 # TODO constant deparsing has been backed out for 5.12
 609 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 610 # tests for deparsing constants which got turned into full typeglobs
 611 # It might be fundamentally impossible to make this work on ithreads, in which
 612 # case the TODO should become a SKIP
 613 warn O_EXCL;
 614 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
 615 warn O_EXCL;
 616 ####
 617 # TODO constant deparsing has been backed out for 5.12
 618 # tests for deparsing of blessed constant with overloaded numification
 619 warn OVERLOADED_NUMIFICATION;
 620 ####
 621 # TODO Only strict 'refs' currently supported
 622 # strict
 623 no strict;
 624 $x;
 625 ####
 626 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
 627 # subsets of warnings
 628 no warnings 'deprecated';
 629 my $x;
 630 ####
 631 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
 632 # CPAN #33708
 633 use strict;
 634 no warnings;
 635
 636 foreach (0..3) {
 637     my $x = 2;
 638     {
 639         my $x if 0;
 640         print ++$x, "\n";
 641     }
 642 }
 643 ####
 644 # no attribute list
 645 my $pi = 4;
 646 ####
 647 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
 648 # := treated as an empty attribute list
 649 no warnings;
 650 my $pi := 4;
 651 >>>>
 652 no warnings;
 653 my $pi = 4;
 654 ####
 655 # : = empty attribute list
 656 my $pi : = 4;
 657 >>>>
 658 my $pi = 4;
 659 ####
 660 # in place sort
 661 our @a;
 662 my @b;
 663 @a = sort @a;
 664 @b = sort @b;
 665 ();
 666 ####
 667 # in place reverse
 668 our @a;
 669 my @b;
 670 @a = reverse @a;
 671 @b = reverse @b;
 672 ();
 673 ####
 674 # #71870 Use of uninitialized value in bitwise and B::Deparse
 675 my($r, $s, @a);
 676 @a = split(/foo/, $s, 0);
 677 $r = qr/foo/;
 678 @a = split(/$r/, $s, 0);
 679 ();
 680 ####
 681 # package declaration before label
 682 {
 683     package Foo;
 684     label: print 123;
 685 }
 686 ####
 687 # shift optimisation
 688 shift;
 689 >>>>
 690 shift();
 691 ####
 692 # shift optimisation
 693 shift @_;
 694 ####
 695 # shift optimisation
 696 pop;
 697 >>>>
 698 pop();
 699 ####
 700 # shift optimisation
 701 pop @_;
 702 ####
 703 #[perl #20444]
 704 "foo" =~ (1 ? /foo/ : /bar/);
 705 "foo" =~ (1 ? y/foo// : /bar/);
 706 "foo" =~ (1 ? s/foo// : /bar/);
 707 >>>>
 708 'foo' =~ ($_ =~ /foo/);
 709 'foo' =~ ($_ =~ tr/fo//);
 710 'foo' =~ ($_ =~ s/foo//);
 711 ####
 712 # Test @threadsv_names under 5005threads
 713 foreach $' (1, 2) {
 714     sleep $';
 715 }
 716 ####
 717 # y///r
 718 tr/a/b/r;
 719 ####
 720 # y/uni/code/
 721 tr/\x{345}/\x{370}/;
 722 ####
 723 # [perl #90898]
 724 glob('a,');
 725 ####
 726 # [perl #91008]
 727 each $@;
 728 keys $~;
 729 values $!;
 730 ####
 731 # readpipe with complex expression
 732 readpipe $a + $b;