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