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;
  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 # [perl #33752]
 174 {
 175   my $code = <<"EOCODE";
 176 {
 177     our \$\x{1e1f}\x{14d}\x{14d};
 178 }
 179 EOCODE
 180   my $deparsed
 181    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
 182   s/$ \n//x for $deparsed, $code;
 183   is $deparsed, $code, 'our $funny_Unicode_chars';
 184 }
 185
 186 done_testing();
 187
 188 __DATA__
 189 # A constant
 190 1;
 191 ####
 192 # Constants in a block
 193 {
 194     no warnings;
 195     '???';
 196     2;
 197 }
 198 ####
 199 # Lexical and simple arithmetic
 200 my $test;
 201 ++$test and $test /= 2;
 202 >>>>
 203 my $test;
 204 $test /= 2 if ++$test;
 205 ####
 206 # list x
 207 -((1, 2) x 2);
 208 ####
 209 # lvalue sub
 210 {
 211     my $test = sub : lvalue {
 212         my $x;
 213     }
 214     ;
 215 }
 216 ####
 217 # method
 218 {
 219     my $test = sub : method {
 220         my $x;
 221     }
 222     ;
 223 }
 224 ####
 225 # block with continue
 226 {
 227     234;
 228 }
 229 continue {
 230     123;
 231 }
 232 ####
 233 # lexical and package scalars
 234 my $x;
 235 print $main::x;
 236 ####
 237 # lexical and package arrays
 238 my @x;
 239 print $main::x[1];
 240 ####
 241 # lexical and package hashes
 242 my %x;
 243 $x{warn()};
 244 ####
 245 # <>
 246 my $foo;
 247 $_ .= <ARGV> . <$foo>;
 248 ####
 249 # \x{}
 250 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 251 ####
 252 # s///e
 253 s/x/'y';/e;
 254 ####
 255 # block
 256 { my $x; }
 257 ####
 258 # while 1
 259 while (1) { my $k; }
 260 ####
 261 # trailing for
 262 my ($x,@a);
 263 $x=1 for @a;
 264 >>>>
 265 my($x, @a);
 266 $x = 1 foreach (@a);
 267 ####
 268 # 2 arguments in a 3 argument for
 269 for (my $i = 0; $i < 2;) {
 270     my $z = 1;
 271 }
 272 ####
 273 # 3 argument for
 274 for (my $i = 0; $i < 2; ++$i) {
 275     my $z = 1;
 276 }
 277 ####
 278 # 3 argument for again
 279 for (my $i = 0; $i < 2; ++$i) {
 280     my $z = 1;
 281 }
 282 ####
 283 # while/continue
 284 my $i;
 285 while ($i) { my $z = 1; } continue { $i = 99; }
 286 ####
 287 # foreach with my
 288 foreach my $i (1, 2) {
 289     my $z = 1;
 290 }
 291 ####
 292 # foreach
 293 my $i;
 294 foreach $i (1, 2) {
 295     my $z = 1;
 296 }
 297 ####
 298 # foreach, 2 mys
 299 my $i;
 300 foreach my $i (1, 2) {
 301     my $z = 1;
 302 }
 303 ####
 304 # foreach
 305 foreach my $i (1, 2) {
 306     my $z = 1;
 307 }
 308 ####
 309 # foreach with our
 310 foreach our $i (1, 2) {
 311     my $z = 1;
 312 }
 313 ####
 314 # foreach with my and our
 315 my $i;
 316 foreach our $i (1, 2) {
 317     my $z = 1;
 318 }
 319 ####
 320 # reverse sort
 321 my @x;
 322 print reverse sort(@x);
 323 ####
 324 # sort with cmp
 325 my @x;
 326 print((sort {$b cmp $a} @x));
 327 ####
 328 # reverse sort with block
 329 my @x;
 330 print((reverse sort {$b <=> $a} @x));
 331 ####
 332 # foreach reverse
 333 our @a;
 334 print $_ foreach (reverse @a);
 335 ####
 336 # foreach reverse (not inplace)
 337 our @a;
 338 print $_ foreach (reverse 1, 2..5);
 339 ####
 340 # bug #38684
 341 our @ary;
 342 @ary = split(' ', 'foo', 0);
 343 ####
 344 # bug #40055
 345 do { () };
 346 ####
 347 # bug #40055
 348 do { my $x = 1; $x };
 349 ####
 350 # <20061012113037.GJ25805@c4.convolution.nl>
 351 my $f = sub {
 352     +{[]};
 353 } ;
 354 ####
 355 # bug #43010
 356 '!@$%'->();
 357 ####
 358 # bug #43010
 359 ::();
 360 ####
 361 # bug #43010
 362 '::::'->();
 363 ####
 364 # bug #43010
 365 &::::;
 366 ####
 367 # variables as method names
 368 my $bar;
 369 'Foo'->$bar('orz');
 370 ####
 371 # constants as method names
 372 'Foo'->bar('orz');
 373 ####
 374 # constants as method names without ()
 375 'Foo'->bar;
 376 ####
 377 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 378 # say
 379 say 'foo';
 380 ####
 381 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 382 # state vars
 383 state $x = 42;
 384 ####
 385 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 386 # state var assignment
 387 {
 388     my $y = (state $x = 42);
 389 }
 390 ####
 391 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 392 # state vars in anoymous subroutines
 393 $a = sub {
 394     state $x;
 395     return $x++;
 396 }
 397 ;
 398 ####
 399 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 400 # each @array;
 401 each @ARGV;
 402 each @$a;
 403 ####
 404 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 405 # keys @array; values @array
 406 keys @$a if keys @ARGV;
 407 values @ARGV if values @$a;
 408 ####
 409 # Anonymous arrays and hashes, and references to them
 410 my $a = {};
 411 my $b = \{};
 412 my $c = [];
 413 my $d = \[];
 414 ####
 415 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 416 # implicit smartmatch in given/when
 417 given ('foo') {
 418     when ('bar') { continue; }
 419     when ($_ ~~ 'quux') { continue; }
 420     default { 0; }
 421 }
 422 ####
 423 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
 424 if ($a) { x(); }
 425 elsif ($b) { x(); }
 426 elsif ($a and $b) { x(); }
 427 elsif ($a or $b) { x(); }
 428 else { x(); }
 429 ####
 430 # interpolation in regexps
 431 my($y, $t);
 432 /x${y}z$t/;
 433 ####
 434 # TODO new undocumented cpan-bug #33708
 435 # cpan-bug #33708
 436 %{$_ || {}}
 437 ####
 438 # TODO hash constants not yet fixed
 439 # cpan-bug #33708
 440 use constant H => { "#" => 1 }; H->{"#"}
 441 ####
 442 # TODO optimized away 0 not yet fixed
 443 # cpan-bug #33708
 444 foreach my $i (@_) { 0 }
 445 ####
 446 # tests with not, not optimized
 447 my $c;
 448 x() unless $a;
 449 x() if not $a and $b;
 450 x() if $a and not $b;
 451 x() unless not $a and $b;
 452 x() unless $a and not $b;
 453 x() if not $a or $b;
 454 x() if $a or not $b;
 455 x() unless not $a or $b;
 456 x() unless $a or not $b;
 457 x() if $a and not $b and $c;
 458 x() if not $a and $b and not $c;
 459 x() unless $a and not $b and $c;
 460 x() unless not $a and $b and not $c;
 461 x() if $a or not $b or $c;
 462 x() if not $a or $b or not $c;
 463 x() unless $a or not $b or $c;
 464 x() unless not $a or $b or not $c;
 465 ####
 466 # tests with not, optimized
 467 my $c;
 468 x() if not $a;
 469 x() unless not $a;
 470 x() if not $a and not $b;
 471 x() unless not $a and not $b;
 472 x() if not $a or not $b;
 473 x() unless not $a or not $b;
 474 x() if not $a and not $b and $c;
 475 x() unless not $a and not $b and $c;
 476 x() if not $a or not $b or $c;
 477 x() unless not $a or not $b or $c;
 478 x() if not $a and not $b and not $c;
 479 x() unless not $a and not $b and not $c;
 480 x() if not $a or not $b or not $c;
 481 x() unless not $a or not $b or not $c;
 482 x() unless not $a or not $b or not $c;
 483 >>>>
 484 my $c;
 485 x() unless $a;
 486 x() if $a;
 487 x() unless $a or $b;
 488 x() if $a or $b;
 489 x() unless $a and $b;
 490 x() if $a and $b;
 491 x() if not $a || $b and $c;
 492 x() unless not $a || $b and $c;
 493 x() if not $a && $b or $c;
 494 x() unless not $a && $b or $c;
 495 x() unless $a or $b or $c;
 496 x() if $a or $b or $c;
 497 x() unless $a and $b and $c;
 498 x() if $a and $b and $c;
 499 x() unless not $a && $b && $c;
 500 ####
 501 # tests that should be constant folded
 502 x() if 1;
 503 x() if GLIPP;
 504 x() if !GLIPP;
 505 x() if GLIPP && GLIPP;
 506 x() if !GLIPP || GLIPP;
 507 x() if do { GLIPP };
 508 x() if do { no warnings 'void'; 5; GLIPP };
 509 x() if do { !GLIPP };
 510 if (GLIPP) { x() } else { z() }
 511 if (!GLIPP) { x() } else { z() }
 512 if (GLIPP) { x() } elsif (GLIPP) { z() }
 513 if (!GLIPP) { x() } elsif (GLIPP) { z() }
 514 if (GLIPP) { x() } elsif (!GLIPP) { z() }
 515 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
 516 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
 517 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 518 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 519 >>>>
 520 x();
 521 x();
 522 '???';
 523 x();
 524 x();
 525 x();
 526 x();
 527 do {
 528     '???'
 529 };
 530 do {
 531     x()
 532 };
 533 do {
 534     z()
 535 };
 536 do {
 537     x()
 538 };
 539 do {
 540     z()
 541 };
 542 do {
 543     x()
 544 };
 545 '???';
 546 do {
 547     t()
 548 };
 549 '???';
 550 !1;
 551 ####
 552 # TODO constant deparsing has been backed out for 5.12
 553 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 554 # tests that shouldn't be constant folded
 555 # It might be fundamentally impossible to make this work on ithreads, in which
 556 # case the TODO should become a SKIP
 557 x() if $a;
 558 if ($a == 1) { x() } elsif ($b == 2) { z() }
 559 if (do { foo(); GLIPP }) { x() }
 560 if (do { $a++; GLIPP }) { x() }
 561 >>>>
 562 x() if $a;
 563 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
 564 if (do { foo(); GLIPP }) { x(); }
 565 if (do { ++$a; GLIPP }) { x(); }
 566 ####
 567 # TODO constant deparsing has been backed out for 5.12
 568 # tests for deparsing constants
 569 warn PI;
 570 ####
 571 # TODO constant deparsing has been backed out for 5.12
 572 # tests for deparsing imported constants
 573 warn O_TRUNC;
 574 ####
 575 # TODO constant deparsing has been backed out for 5.12
 576 # tests for deparsing re-exported constants
 577 warn O_CREAT;
 578 ####
 579 # TODO constant deparsing has been backed out for 5.12
 580 # tests for deparsing imported constants that got deleted from the original namespace
 581 warn O_APPEND;
 582 ####
 583 # TODO constant deparsing has been backed out for 5.12
 584 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 585 # tests for deparsing constants which got turned into full typeglobs
 586 # It might be fundamentally impossible to make this work on ithreads, in which
 587 # case the TODO should become a SKIP
 588 warn O_EXCL;
 589 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
 590 warn O_EXCL;
 591 ####
 592 # TODO constant deparsing has been backed out for 5.12
 593 # tests for deparsing of blessed constant with overloaded numification
 594 warn OVERLOADED_NUMIFICATION;
 595 ####
 596 # TODO Only strict 'refs' currently supported
 597 # strict
 598 no strict;
 599 $x;
 600 ####
 601 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
 602 # subsets of warnings
 603 no warnings 'deprecated';
 604 my $x;
 605 ####
 606 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
 607 # CPAN #33708
 608 use strict;
 609 no warnings;
 610
 611 foreach (0..3) {
 612     my $x = 2;
 613     {
 614         my $x if 0;
 615         print ++$x, "\n";
 616     }
 617 }
 618 ####
 619 # no attribute list
 620 my $pi = 4;
 621 ####
 622 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
 623 # := treated as an empty attribute list
 624 no warnings;
 625 my $pi := 4;
 626 >>>>
 627 no warnings;
 628 my $pi = 4;
 629 ####
 630 # : = empty attribute list
 631 my $pi : = 4;
 632 >>>>
 633 my $pi = 4;
 634 ####
 635 # in place sort
 636 our @a;
 637 my @b;
 638 @a = sort @a;
 639 @b = sort @b;
 640 ();
 641 ####
 642 # in place reverse
 643 our @a;
 644 my @b;
 645 @a = reverse @a;
 646 @b = reverse @b;
 647 ();
 648 ####
 649 # #71870 Use of uninitialized value in bitwise and B::Deparse
 650 my($r, $s, @a);
 651 @a = split(/foo/, $s, 0);
 652 $r = qr/foo/;
 653 @a = split(/$r/, $s, 0);
 654 ();
 655 ####
 656 # package declaration before label
 657 {
 658     package Foo;
 659     label: print 123;
 660 }
 661 ####
 662 # shift optimisation
 663 shift;
 664 >>>>
 665 shift();
 666 ####
 667 # shift optimisation
 668 shift @_;
 669 ####
 670 # shift optimisation
 671 pop;
 672 >>>>
 673 pop();
 674 ####
 675 # shift optimisation
 676 pop @_;
 677 ####
 678 #[perl #20444]
 679 "foo" =~ (1 ? /foo/ : /bar/);
 680 "foo" =~ (1 ? y/foo// : /bar/);
 681 "foo" =~ (1 ? s/foo// : /bar/);
 682 >>>>
 683 'foo' =~ ($_ =~ /foo/);
 684 'foo' =~ ($_ =~ tr/fo//);
 685 'foo' =~ ($_ =~ s/foo//);
 686 ####
 687 # Test @threadsv_names under 5005threads
 688 foreach $' (1, 2) {
 689     sleep $';
 690 }
 691 ####
 692 # y///r
 693 tr/a/b/r;
 694 ####
 695 # y/uni/code/
 696 tr/\x{345}/\x{370}/;