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