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