This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
optree_check.t fix-ups
[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::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             @     p+
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