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