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