lib/B/Deparse-core.t

   1 #!./perl
   2
   3 # Test the core keywords.
   4 #
   5 # Initially this test file just checked that CORE::foo got correctly
   6 # deparsed as CORE::foo, hence the name. It's since been expanded
   7 # to fully test both CORE:: verses none, plus that any arguments
   8 # are correctly deparsed. It also cross-checks against regen/keywords.pl
   9 # to make sure we've tested all keywords, and with the correct strength.
  10 #
  11 # A keyword can be either weak or strong. Strong keywords can never be
  12 # overridden, while weak ones can. So deparsing of weak keywords depends
  13 # on whether a sub of that name has been created:
  14 #
  15 # for both:         keyword(..) deparsed as keyword(..)
  16 # for weak:   CORE::keyword(..) deparsed as CORE::keyword(..)
  17 # for strong: CORE::keyword(..) deparsed as keyword(..)
  18 #
  19 # Three permutations of lex/nonlex args are checked for:
  20 #
  21 #   foo($a,$b,$c,...)
  22 #   foo(my $a,$b,$c,...)
  23 #   my ($a,$b,$c,...); foo($a,$b,$c,...)
  24 #
  25 # Note that tests for prefixing feature.pm-enabled keywords with CORE:: when
  26 # feature.pm is not enabled are in deparse.t, as they fit that format better.
  27
  28
  29 BEGIN {
  30     require Config;
  31     if (($Config::Config{extensions} !~ /\bB\b/) ){
  32         print "1..0 # Skip -- Perl configured without B module\n";
  33         exit 0;
  34     }
  35 }
  36
  37 use strict;
  38 use Test::More;
  39 plan tests => 4006;
  40
  41 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
  42                                     # logic to add CORE::
  43 no warnings 'experimental::autoderef';
  44 use B::Deparse;
  45 my $deparse = new B::Deparse;
  46
  47 my %SEEN;
  48 my %SEEN_STRENGH;
  49
  50 # for a given keyword, create a sub of that name, then
  51 # deparse "() = $expr", and see if it matches $expected_expr
  52
  53 sub testit {
  54     my ($keyword, $expr, $expected_expr, $lexsub) = @_;
  55
  56     $expected_expr //= $expr;
  57     $SEEN{$keyword} = 1;
  58
  59
  60     # lex=0:   () = foo($a,$b,$c)
  61     # lex=1:   my ($a,$b); () = foo($a,$b,$c)
  62     # lex=2:   () = foo(my $a,$b,$c)
  63     for my $lex (0, 1, 2) {
  64         if ($lex) {
  65             next if $keyword =~ /local|our|state|my/;
  66         }
  67         my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n    " : "";
  68
  69         if ($lex == 2) {
  70             my $repl = 'my $a';
  71             if ($expr =~ 'CORE::do') {
  72                 # do foo() is a syntax error, so B::Deparse emits
  73                 # do (foo()), but does not distinguish between foo and my,
  74                 # because it is too complicated.
  75                 $repl = '(my $a)';
  76             }
  77             s/\$a/$repl/ for $expr, $expected_expr;
  78         }
  79
  80         my $desc = "$keyword: lex=$lex $expr => $expected_expr";
  81         $desc .= " (lex sub)" if $lexsub;
  82
  83
  84         my $code_ref;
  85         if ($lexsub) {
  86             package lexsubtest;
  87             no warnings 'experimental::lexical_subs';
  88             use feature 'lexical_subs';
  89             no strict 'vars';
  90             $code_ref =
  91                 eval "sub { state sub $keyword; ${vars}() = $expr }"
  92                             || die "$@ in $expr";
  93         }
  94         else {
  95             package test;
  96             use subs ();
  97             import subs $keyword;
  98             $code_ref = eval "no strict 'vars'; sub { ${vars}() = $expr }"
  99                             or die "$@ in $expr";
 100         }
 101
 102         my $got_text = $deparse->coderef2text($code_ref);
 103
 104         unless ($got_text =~ /
 105     package (?:lexsub)?test;
 106     BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"}
 107     use strict 'refs', 'subs';
 108     use feature [^\n]+
 109     \Q$vars\E\(\) = (.*)
 110 }/s) {
 111             ::fail($desc);
 112             ::diag("couldn't extract line from boilerplate\n");
 113             ::diag($got_text);
 114             return;
 115         }
 116
 117         my $got_expr = $1;
 118         is $got_expr, $expected_expr, $desc;
 119     }
 120 }
 121
 122
 123 # Deparse can't distinguish 'and' from '&&' etc
 124 my %infix_map = qw(and && or ||);
 125
 126
 127 # test a keyword that is a binary infix operator, like 'cmp'.
 128 # $parens - "$a op $b" is deparsed as "($a op $b)"
 129 # $strong - keyword is strong
 130
 131 sub do_infix_keyword {
 132     my ($keyword, $parens, $strong) = @_;
 133     $SEEN_STRENGH{$keyword} = $strong;
 134     my $expr = "(\$a $keyword \$b)";
 135     my $nkey = $infix_map{$keyword} // $keyword;
 136     my $expr = "(\$a $keyword \$b)";
 137     my $exp = "\$a $nkey \$b";
 138     $exp = "($exp)" if $parens;
 139     $exp .= ";";
 140     # with infix notation, a keyword is always interpreted as core,
 141     # so no need for Deparse to disambiguate with CORE::
 142     testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
 143     testit $keyword, "(\$a $keyword \$b)", $exp;
 144     testit $keyword, "(\$a CORE::$keyword \$b)", $exp, 1;
 145     testit $keyword, "(\$a $keyword \$b)", $exp, 1;
 146     if (!$strong) {
 147         # B::Deparse fully qualifies any sub whose name is a keyword,
 148         # imported or not, since the importedness may not be reproduced by
 149         # the deparsed code.  x is special.
 150         my $pre = "test::" x ($keyword ne 'x');
 151         testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);";
 152     }
 153     testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1;
 154 }
 155
 156 # test a keyword that is as tandard op/function, like 'index(...)'.
 157 # narg    - how many args to test it with
 158 # $parens - "foo $a, $b" is deparsed as "foo($a, $b)"
 159 # $dollar - an extra '$_' arg will appear in the deparsed output
 160 # $strong - keyword is strong
 161
 162
 163 sub do_std_keyword {
 164     my ($keyword, $narg, $parens, $dollar, $strong) = @_;
 165
 166     $SEEN_STRENGH{$keyword} = $strong;
 167
 168     for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
 169       for my $lexsub (0,1) { # if true, define lex sub
 170         my @code;
 171         for my $do_exp(0, 1) { # first create expr, then expected-expr
 172             my @args = map "\$$_", (undef,"a".."z")[1..$narg];
 173             push @args, '$_'
 174                 if $dollar && $do_exp && ($strong && !$lexsub or $core);
 175             my $args = join(', ', @args);
 176              # XXX $lex_parens is temporary, until lex subs are
 177              #     deparsed properly.
 178             my $lex_parens =
 179                 !$core && $do_exp && $lexsub && $keyword ne 'map';
 180             $args = ((!$core && !$strong) || $parens || $lex_parens)
 181                         ? "($args)"
 182                         :  @args ? " $args" : "";
 183             push @code, (($core && !($do_exp && $strong))
 184                          ? "CORE::"
 185                          : $lexsub && $do_exp
 186                            ? "CORE::" x $core
 187                            : $do_exp && !$core && !$strong ? "test::" : "")
 188                                                         . "$keyword$args;";
 189         }
 190         # code[0]: to run; code[1]: expected
 191         testit $keyword, @code, $lexsub;
 192       }
 193     }
 194 }
 195
 196
 197 while (<DATA>) {
 198     chomp;
 199     s/#.*//;
 200     next unless /\S/;
 201
 202     my @fields = split;
 203     die "not 3 fields" unless @fields == 3;
 204     my ($keyword, $args, $flags) = @fields;
 205
 206     $args = '012' if $args eq '@';
 207
 208     my $parens  = $flags =~ s/p//;
 209     my $invert1 = $flags =~ s/1//;
 210     my $dollar  = $flags =~ s/\$//;
 211     my $strong  = $flags =~ s/\+//;
 212     die "unrecognised flag(s): '$flags'" unless $flags =~ /^-?$/;
 213
 214     if ($args eq 'B') { # binary infix
 215         die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar;
 216         die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1;
 217         do_infix_keyword($keyword, $parens, $strong);
 218     }
 219     else {
 220         my @narg = split //, $args;
 221         for my $n (0..$#narg) {
 222             my $narg = $narg[$n];
 223             my $p = $parens;
 224             $p = !$p if ($n == 0 && $invert1);
 225             do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong);
 226         }
 227     }
 228 }
 229
 230
 231 # Special cases
 232
 233 testit dbmopen  => 'CORE::dbmopen(%foo, $bar, $baz);';
 234 testit dbmclose => 'CORE::dbmclose %foo;';
 235
 236 testit delete   => 'CORE::delete $h{\'foo\'};', 'delete $h{\'foo\'};';
 237 testit delete   => 'CORE::delete $h{\'foo\'};', undef, 1;
 238 testit delete   => 'CORE::delete @h{\'foo\'};', undef, 1;
 239 testit delete   => 'CORE::delete $h[0];', undef, 1;
 240 testit delete   => 'CORE::delete @h[0];', undef, 1;
 241 testit delete   => 'delete $h{\'foo\'};',       'delete $h{\'foo\'};';
 242
 243 # do is listed as strong, but only do { block } is strong;
 244 # do $file is weak,  so test it separately here
 245 testit do       => 'CORE::do $a;';
 246 testit do       => 'do $a;',                    'test::do($a);';
 247 testit do       => 'CORE::do { 1 }',
 248                    "do {\n        1\n    };";
 249 testit do       => 'CORE::do { 1 }',
 250                    "CORE::do {\n        1\n    };", 1;
 251 testit do       => 'do { 1 };',
 252                    "do {\n        1\n    };";
 253
 254 testit each     => 'CORE::each %bar;';
 255
 256 testit eof      => 'CORE::eof();';
 257
 258 testit exists   => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
 259 testit exists   => 'CORE::exists $h{\'foo\'};', undef, 1;
 260 testit exists   => 'CORE::exists &foo;', undef, 1;
 261 testit exists   => 'CORE::exists $h[0];', undef, 1;
 262 testit exists   => 'exists $h{\'foo\'};',       'exists $h{\'foo\'};';
 263
 264 testit exec     => 'CORE::exec($foo $bar);';
 265
 266 testit glob     => 'glob;',                       'glob($_);';
 267 testit glob     => 'CORE::glob;',                 'CORE::glob($_);';
 268 testit glob     => 'glob $a;',                    'glob($a);';
 269 testit glob     => 'CORE::glob $a;',              'CORE::glob($a);';
 270
 271 testit grep     => 'CORE::grep { $a } $b, $c',    'grep({$a;} $b, $c);';
 272
 273 testit keys     => 'CORE::keys %bar;';
 274
 275 testit map      => 'CORE::map { $a } $b, $c',    'map({$a;} $b, $c);';
 276
 277 testit not      => '3 unless CORE::not $a && $b;';
 278
 279 testit readline => 'CORE::readline $a . $b;';
 280
 281 testit readpipe => 'CORE::readpipe $a + $b;';
 282
 283 testit reverse  => 'CORE::reverse sort(@foo);';
 284
 285 # note that the test does '() = split...' which is why the
 286 # limit is optimised to 1
 287 testit split    => 'split;',                     q{split(' ', $_, 1);};
 288 testit split    => 'CORE::split;',               q{split(' ', $_, 1);};
 289 testit split    => 'split $a;',                  q{split(/$a/u, $_, 1);};
 290 testit split    => 'CORE::split $a;',            q{split(/$a/u, $_, 1);};
 291 testit split    => 'split $a, $b;',              q{split(/$a/u, $b, 1);};
 292 testit split    => 'CORE::split $a, $b;',        q{split(/$a/u, $b, 1);};
 293 testit split    => 'split $a, $b, $c;',          q{split(/$a/u, $b, $c);};
 294 testit split    => 'CORE::split $a, $b, $c;',    q{split(/$a/u, $b, $c);};
 295
 296 testit sub      => 'CORE::sub { $a, $b }',
 297                         "sub {\n        \$a, \$b;\n    }\n    ;";
 298
 299 testit system   => 'CORE::system($foo $bar);';
 300
 301 testit values   => 'CORE::values %bar;';
 302
 303
 304 # XXX These are deparsed wrapped in parens.
 305 # whether they should be, I don't know!
 306
 307 testit dump     => '(CORE::dump);';
 308 testit dump     => '(CORE::dump FOO);';
 309 testit goto     => '(CORE::goto);',     '(goto);';
 310 testit goto     => '(CORE::goto FOO);', '(goto FOO);';
 311 testit last     => '(CORE::last);',     '(last);';
 312 testit last     => '(CORE::last FOO);', '(last FOO);';
 313 testit next     => '(CORE::next);',     '(next);';
 314 testit next     => '(CORE::next FOO);', '(next FOO);';
 315 testit redo     => '(CORE::redo);',     '(redo);';
 316 testit redo     => '(CORE::redo FOO);', '(redo FOO);';
 317 testit redo     => '(CORE::redo);',     '(redo);';
 318 testit redo     => '(CORE::redo FOO);', '(redo FOO);';
 319 testit return   => '(return);',         '(return);';
 320 testit return   => '(CORE::return);',   '(return);';
 321
 322 # these are the keywords I couldn't think how to test within this framework
 323
 324 my %not_tested = map { $_ => 1} qw(
 325     __DATA__
 326     __END__
 327     __FILE__
 328     __LINE__
 329     __PACKAGE__
 330     AUTOLOAD
 331     BEGIN
 332     CHECK
 333     CORE
 334     DESTROY
 335     END
 336     INIT
 337     UNITCHECK
 338     default
 339     else
 340     elsif
 341     for
 342     foreach
 343     format
 344     given
 345     if
 346     m
 347     no
 348     package
 349     q
 350     qq
 351     qr
 352     qw
 353     qx
 354     require
 355     s
 356     tr
 357     unless
 358     until
 359     use
 360     when
 361     while
 362     y
 363 );
 364
 365
 366
 367 # Sanity check against keyword data:
 368 # make sure we haven't missed any keywords,
 369 # and that we got the strength right.
 370
 371 SKIP:
 372 {
 373     skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
 374     my $count = 0;
 375     my $file = '../regen/keywords.pl';
 376     my $pass = 1;
 377     if (open my $fh, '<', $file) {
 378         while (<$fh>) {
 379             last if /^__END__$/;
 380         }
 381         while (<$fh>) {
 382             next unless /^([+\-])(\w+)$/;
 383             my ($strength, $key) = ($1, $2);
 384             $strength = ($strength eq '+') ? 1 : 0;
 385             $count++;
 386             if (!$SEEN{$key} && !$not_tested{$key}) {
 387                 diag("keyword '$key' seen in $file, but not tested here!!");
 388                 $pass = 0;
 389             }
 390             if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) {
 391                 diag("keyword '$key' strengh as seen in $file doen't match here!!");
 392                 $pass = 0;
 393             }
 394         }
 395     }
 396     else {
 397         diag("Can't open $file: $!");
 398         $pass = 0;
 399     }
 400     # insanity check
 401     if ($count < 200) {
 402         diag("Saw $count keywords: less than 200!");
 403         $pass = 0;
 404     }
 405     ok($pass, "sanity checks");
 406 }
 407
 408
 409
 410 __DATA__
 411 #
 412 # format:
 413 #   keyword args flags
 414 #
 415 # args consists of:
 416 #  * one of more digits indictating which lengths of args the function accepts,
 417 #  * or 'B' to indiate a binary infix operator,
 418 #  * or '@' to indicate a list function.
 419 #
 420 # Flags consists of the following (or '-' if no flags):
 421 #    + : strong keyword: can't be overrriden
 422 #    p : the args are parenthesised on deparsing;
 423 #    1 : parenthesising of 1st arg length is inverted
 424 #        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
 425 #    $ : on the first argument length, there is an implicit extra
 426 #        '$_' arg which will appear on deparsing;
 427 #        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
 428 #                     and deparsed as: foo(a1, $_); foo(a1,a2);
 429 #
 430 # XXX Note that we really should get this data from regen/keywords.pl
 431 # and regen/opcodes (augmented if necessary), rather than duplicating it
 432 # here.
 433
 434 __SUB__          0     -
 435 abs              01    $
 436 accept           2     p
 437 alarm            01    $
 438 and              B     -
 439 atan2            2     p
 440 bind             2     p
 441 binmode          12    p
 442 bless            1     p
 443 break            0     -
 444 caller           0     -
 445 chdir            01    -
 446 chmod            @     p1
 447 chomp            @     $
 448 chop             @     $
 449 chown            @     p1
 450 chr              01    $
 451 chroot           01    $
 452 close            01    -
 453 closedir         1     -
 454 cmp              B     -
 455 connect          2     p
 456 continue         0     -
 457 cos              01    $
 458 crypt            2     p
 459 # dbmopen  handled specially
 460 # dbmclose handled specially
 461 defined          01    $+
 462 # delete handled specially
 463 die              @     p1
 464 # do handled specially
 465 # dump handled specially
 466 each             1     - # also tested specially
 467 endgrent         0     -
 468 endhostent       0     -
 469 endnetent        0     -
 470 endprotoent      0     -
 471 endpwent         0     -
 472 endservent       0     -
 473 eof              01    - # also tested specially
 474 eq               B     -
 475 eval             01    $+
 476 evalbytes        01    $
 477 exec             @     p1 # also tested specially
 478 # exists handled specially
 479 exit             01    -
 480 exp              01    $
 481 fc               01    $
 482 fcntl            3     p
 483 fileno           1     -
 484 flock            2     p
 485 fork             0     -
 486 formline         2     p
 487 ge               B     -
 488 getc             01    -
 489 getgrent         0     -
 490 getgrgid         1     -
 491 getgrnam         1     -
 492 gethostbyaddr    2     p
 493 gethostbyname    1     -
 494 gethostent       0     -
 495 getlogin         0     -
 496 getnetbyaddr     2     p
 497 getnetbyname     1     -
 498 getnetent        0     -
 499 getpeername      1     -
 500 getpgrp          1     -
 501 getppid          0     -
 502 getpriority      2     p
 503 getprotobyname   1     -
 504 getprotobynumber 1     p
 505 getprotoent      0     -
 506 getpwent         0     -
 507 getpwnam         1     -
 508 getpwuid         1     -
 509 getservbyname    2     p
 510 getservbyport    2     p
 511 getservent       0     -
 512 getsockname      1     -
 513 getsockopt       3     p
 514 # given handled specially
 515 grep             123   p+ # also tested specially
 516 # glob handled specially
 517 # goto handled specially
 518 gmtime           01    -
 519 gt               B     -
 520 hex              01    $
 521 index            23    p
 522 int              01    $
 523 ioctl            3     p
 524 join             13    p
 525 keys             1     - # also tested specially
 526 kill             123   p
 527 # last handled specially
 528 lc               01    $
 529 lcfirst          01    $
 530 le               B     -
 531 length           01    $
 532 link             2     p
 533 listen           2     p
 534 local            1     p+
 535 localtime        01    -
 536 lock             1     -
 537 log              01    $
 538 lstat            01    $
 539 lt               B     -
 540 map              123   p+ # also tested specially
 541 mkdir            @     p$
 542 msgctl           3     p
 543 msgget           2     p
 544 msgrcv           5     p
 545 msgsnd           3     p
 546 my               123   p+ # skip with 0 args, as my() => ()
 547 ne               B     -
 548 # next handled specially
 549 # not handled specially
 550 oct              01    $
 551 open             12345 p
 552 opendir          2     p
 553 or               B     -
 554 ord              01    $
 555 our              123   p+ # skip with 0 args, as our() => ()
 556 pack             123   p
 557 pipe             2     p
 558 pop              01    1
 559 pos              01    $+
 560 print            @     p$+
 561 printf           @     p$+
 562 prototype        1     +
 563 push             123   p
 564 quotemeta        01    $
 565 rand             01    -
 566 read             34    p
 567 readdir          1     -
 568 # readline handled specially
 569 readlink         01    $
 570 # readpipe handled specially
 571 recv             4     p
 572 # redo handled specially
 573 ref              01    $
 574 rename           2     p
 575 # XXX This code prints 'Undefined subroutine &main::require called':
 576 #   use subs (); import subs 'require';
 577 #   eval q[no strict 'vars'; sub { () = require; }]; print $@;
 578 # so disable for now
 579 #require          01    $+
 580 reset            01    -
 581 # return handled specially
 582 reverse          @     p1 # also tested specially
 583 rewinddir        1     -
 584 rindex           23    p
 585 rmdir            01    $
 586 say              @     p$+
 587 scalar           1     +
 588 seek             3     p
 589 seekdir          2     p
 590 select           014   p1
 591 semctl           4     p
 592 semget           3     p
 593 semop            2     p
 594 send             34    p
 595 setgrent         0     -
 596 sethostent       1     -
 597 setnetent        1     -
 598 setpgrp          2     p
 599 setpriority      3     p
 600 setprotoent      1     -
 601 setpwent         0     -
 602 setservent       1     -
 603 setsockopt       4     p
 604 shift            01    1
 605 shmctl           3     p
 606 shmget           3     p
 607 shmread          4     p
 608 shmwrite         4     p
 609 shutdown         2     p
 610 sin              01    $
 611 sleep            01    -
 612 socket           4     p
 613 socketpair       5     p
 614 sort             @     p1+
 615 # split handled specially
 616 splice           12345 p
 617 sprintf          123   p
 618 sqrt             01    $
 619 srand            01    -
 620 stat             01    $
 621 state            123   p+ # skip with 0 args, as state() => ()
 622 study            01    $+
 623 # sub handled specially
 624 substr           234   p
 625 symlink          2     p
 626 syscall          2     p
 627 sysopen          34    p
 628 sysread          34    p
 629 sysseek          3     p
 630 system           @     p1 # also tested specially
 631 syswrite         234   p
 632 tell             01    -
 633 telldir          1     -
 634 tie              234   p
 635 tied             1     -
 636 time             0     -
 637 times            0     -
 638 truncate         2     p
 639 uc               01    $
 640 ucfirst          01    $
 641 umask            01    -
 642 undef            01    +
 643 unlink           @     p$
 644 unpack           12    p$
 645 unshift          1     p
 646 untie            1     -
 647 utime            @     p1
 648 values           1     - # also tested specially
 649 vec              3     p
 650 wait             0     -
 651 waitpid          2     p
 652 wantarray        0     -
 653 warn             @     p1
 654 write            01    -
 655 x                B     -
 656 xor              B     p