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