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