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