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