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