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