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