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