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