This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Deparse-core.t: Fix ineffective tests
[perl5.git] / lib / B / Deparse-core.t
... / ...
CommitLineData
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
29BEGIN {
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
37use strict;
38use Test::More;
39plan tests => 2071;
40
41use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
42 # logic to add CORE::
43no warnings 'experimental::autoderef';
44use B::Deparse;
45my $deparse = new B::Deparse;
46
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
59
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/;
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
94 unless ($got_text =~ /^\{
95 package test;
96 BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"}
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
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) {
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.
138 my $pre = "test::" x ($keyword ne 'x');
139 testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);";
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" : "";
164 push @code, (($core && !($do_exp && $strong))
165 ? "CORE::"
166 : $do_exp && !$core && !$strong ? "test::" : "")
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 }
205}
206
207
208# Special cases
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;';
219testit do => 'do $a;', 'test::do($a);';
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
234testit glob => 'glob;', 'glob($_);';
235testit glob => 'CORE::glob;', 'CORE::glob($_);';
236testit glob => 'glob $a;', 'glob($a);';
237testit glob => 'CORE::glob $a;', 'CORE::glob($a);';
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__
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
339SKIP:
340{
341 skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
342 my $count = 0;
343 my $file = '../regen/keywords.pl';
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
Unnamed repository; edit this file 'description' to name the repository.