This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove __SUB__ from Deparse-core.t exception list
[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     AUTOLOAD
293     BEGIN
294     CHECK
295     CORE
296     DESTROY
297     END
298     INIT
299     UNITCHECK
300     default
301     else
302     elsif
303     for
304     foreach
305     format
306     given
307     if
308     m
309     no
310     package
311     q
312     qq
313     qr
314     qw
315     qx
316     require
317     s
318     tr
319     unless
320     until
321     use
322     when
323     while
324     y
325 );
326
327
328
329 # Sanity check against keyword data:
330 # make sure we haven't missed any keywords,
331 # and that we got the strength right.
332
333 SKIP:
334 {
335     skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
336     my $count = 0;
337     my $file = '../regen/keywords.pl';
338     my $pass = 1;
339     if (open my $fh, '<', $file) {
340         while (<$fh>) {
341             last if /^__END__$/;
342         }
343         while (<$fh>) {
344             next unless /^([+\-])(\w+)$/;
345             my ($strength, $key) = ($1, $2);
346             $strength = ($strength eq '+') ? 1 : 0;
347             $count++;
348             if (!$SEEN{$key} && !$not_tested{$key}) {
349                 diag("keyword '$key' seen in $file, but not tested here!!");
350                 $pass = 0;
351             }
352             if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) {
353                 diag("keyword '$key' strengh as seen in $file doen't match here!!");
354                 $pass = 0;
355             }
356         }
357     }
358     else {
359         diag("Can't open $file: $!");
360         $pass = 0;
361     }
362     # insanity check
363     if ($count < 200) {
364         diag("Saw $count keywords: less than 200!");
365         $pass = 0;
366     }
367     ok($pass, "sanity checks");
368 }
369
370
371
372 __DATA__
373 #
374 # format:
375 #   keyword args flags
376 #
377 # args consists of:
378 #  * one of more digits indictating which lengths of args the function accepts,
379 #  * or 'B' to indiate a binary infix operator,
380 #  * or '@' to indicate a list function.
381 #
382 # Flags consists of the following (or '-' if no flags):
383 #    + : strong keyword: can't be overrriden
384 #    p : the args are parenthesised on deparsing;
385 #    1 : parenthesising of 1st arg length is inverted
386 #        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
387 #    $ : on the first argument length, there is an implicit extra
388 #        '$_' arg which will appear on deparsing;
389 #        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
390 #                     and deparsed as: foo(a1, $_); foo(a1,a2);
391 #
392 # XXX Note that we really should get this data from regen/keywords.pl
393 # and regen/opcodes (augmented if necessary), rather than duplicating it
394 # here.
395
396 __SUB__          0     -
397 abs              01    $
398 accept           2     p
399 alarm            01    $
400 and              B     -
401 atan2            2     p
402 bind             2     p
403 binmode          12    p
404 bless            1     p
405 break            0     -
406 caller           0     -
407 chdir            01    -
408 chmod            @     p1
409 chomp            @     $
410 chop             @     $
411 chown            @     p1
412 chr              01    $
413 chroot           01    $
414 close            01    -
415 closedir         1     -
416 cmp              B     -
417 connect          2     p
418 continue         0     -
419 cos              01    $
420 crypt            2     p
421 # dbmopen  handled specially
422 # dbmclose handled specially
423 defined          01    $+
424 # delete handled specially
425 die              @     p1
426 # do handled specially
427 # dump handled specially
428 each             1     - # also tested specially
429 endgrent         0     -
430 endhostent       0     -
431 endnetent        0     -
432 endprotoent      0     -
433 endpwent         0     -
434 endservent       0     -
435 eof              01    - # also tested specially
436 eq               B     -
437 eval             01    $+
438 evalbytes        01    $
439 exec             @     p1 # also tested specially
440 # exists handled specially
441 exit             01    -
442 exp              01    $
443 fc               01    $
444 fcntl            3     p
445 fileno           1     -
446 flock            2     p
447 fork             0     -
448 formline         2     p
449 ge               B     -
450 getc             01    -
451 getgrent         0     -
452 getgrgid         1     -
453 getgrnam         1     -
454 gethostbyaddr    2     p
455 gethostbyname    1     -
456 gethostent       0     -
457 getlogin         0     -
458 getnetbyaddr     2     p
459 getnetbyname     1     -
460 getnetent        0     -
461 getpeername      1     -
462 getpgrp          1     -
463 getppid          0     -
464 getpriority      2     p
465 getprotobyname   1     -
466 getprotobynumber 1     p
467 getprotoent      0     -
468 getpwent         0     -
469 getpwnam         1     -
470 getpwuid         1     -
471 getservbyname    2     p
472 getservbyport    2     p
473 getservent       0     -
474 getsockname      1     -
475 getsockopt       3     p
476 # given handled specially
477 grep             123   p+ # also tested specially
478 # glob handled specially
479 # goto handled specially
480 gmtime           01    -
481 gt               B     -
482 hex              01    $
483 index            23    p
484 int              01    $
485 ioctl            3     p
486 join             123   p
487 keys             1     - # also tested specially
488 kill             123   p
489 # last handled specially
490 lc               01    $
491 lcfirst          01    $
492 le               B     -
493 length           01    $
494 link             2     p
495 listen           2     p
496 local            1     p+
497 localtime        01    -
498 lock             1     -
499 log              01    $
500 lstat            01    $
501 lt               B     -
502 map              123   p+ # also tested specially
503 mkdir            @     p$
504 msgctl           3     p
505 msgget           2     p
506 msgrcv           5     p
507 msgsnd           3     p
508 my               123   p+ # skip with 0 args, as my() => ()
509 ne               B     -
510 # next handled specially
511 # not handled specially
512 oct              01    $
513 open             12345 p
514 opendir          2     p
515 or               B     -
516 ord              01    $
517 our              123   p+ # skip with 0 args, as our() => ()
518 pack             123   p
519 pipe             2     p
520 pop              01    1
521 pos              01    $+
522 print            @     p$+
523 printf           @     p$+
524 prototype        1     +
525 push             123   p
526 quotemeta        01    $
527 rand             01    -
528 read             34    p
529 readdir          1     -
530 # readline handled specially
531 readlink         01    $
532 # readpipe handled specially
533 recv             4     p
534 # redo handled specially
535 ref              01    $
536 rename           2     p
537 # XXX This code prints 'Undefined subroutine &main::require called':
538 #   use subs (); import subs 'require';
539 #   eval q[no strict 'vars'; sub { () = require; }]; print $@;
540 # so disable for now
541 #require          01    $+
542 reset            01    -
543 # return handled specially
544 reverse          @     p1 # also tested specially
545 rewinddir        1     -
546 rindex           23    p
547 rmdir            01    $
548 say              @     p$+
549 scalar           1     +
550 seek             3     p
551 seekdir          2     p
552 select           014   p1
553 semctl           4     p
554 semget           3     p
555 semop            2     p
556 send             34    p
557 setgrent         0     -
558 sethostent       1     -
559 setnetent        1     -
560 setpgrp          2     p
561 setpriority      3     p
562 setprotoent      1     -
563 setpwent         0     -
564 setservent       1     -
565 setsockopt       4     p
566 shift            01    1
567 shmctl           3     p
568 shmget           3     p
569 shmread          4     p
570 shmwrite         4     p
571 shutdown         2     p
572 sin              01    $
573 sleep            01    -
574 socket           4     p
575 socketpair       5     p
576 sort             @     p+
577 # split handled specially
578 splice           12345 p
579 sprintf          123   p
580 sqrt             01    $
581 srand            01    -
582 stat             01    $
583 state            123   p+ # skip with 0 args, as state() => ()
584 study            01    $+
585 # sub handled specially
586 substr           234   p
587 symlink          2     p
588 syscall          2     p
589 sysopen          34    p
590 sysread          34    p
591 sysseek          3     p
592 system           @     p1 # also tested specially
593 syswrite         234   p
594 tell             01    -
595 telldir          1     -
596 tie              234   p
597 tied             1     -
598 time             0     -
599 times            0     -
600 truncate         2     p
601 uc               01    $
602 ucfirst          01    $
603 umask            01    -
604 undef            01    +
605 unlink           @     p$
606 unpack           12    p$
607 unshift          1     p
608 untie            1     -
609 utime            @     p1
610 values           1     - # also tested specially
611 vec              3     p
612 wait             0     -
613 waitpid          2     p
614 wantarray        0     -
615 warn             @     p1
616 write            01    -
617 x                B     -
618 xor              B     p