[perl5.git] / lib / B / Deparse-core.t

#!./perl

# Test the core keywords.
#
# Initially this test file just checked that CORE::foo got correctly
# deparsed as CORE::foo, hence the name. It's since been expanded
# to fully test both CORE:: verses none, plus that any arguments
# are correctly deparsed. It also cross-checks against regen/keywords.pl
# to make sure we've tested all keywords, and with the correct strength.
#
# A keyword can be either weak or strong. Strong keywords can never be
# overridden, while weak ones can. So deparsing of weak keywords depends
# on whether a sub of that name has been created:
#
# for both:         keyword(..) deparsed as keyword(..)
# for weak:   CORE::keyword(..) deparsed as CORE::keyword(..)
# for strong: CORE::keyword(..) deparsed as keyword(..)
#
# Three permutations of lex/nonlex args are checked for:
#
#   foo($a,$b,$c,...)
#   foo(my $a,$b,$c,...)
#   my ($a,$b,$c,...); foo($a,$b,$c,...)
#
# Note that tests for prefixing feature.pm-enabled keywords with CORE:: when
# feature.pm is not enabled are in deparse.t, as they fit that format better.


BEGIN {
    require Config;
    if (($Config::Config{extensions} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
}

use strict;
use Test::More;
plan tests => 4006;

use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                    # logic to add CORE::
no warnings 'experimental::autoderef';
use B::Deparse;
my $deparse = new B::Deparse;

my %SEEN;
my %SEEN_STRENGH;

# for a given keyword, create a sub of that name, then
# deparse "() = $expr", and see if it matches $expected_expr

sub testit {
    my ($keyword, $expr, $expected_expr, $lexsub) = @_;

    $expected_expr //= $expr;
    $SEEN{$keyword} = 1;


    # lex=0:   () = foo($a,$b,$c)
    # lex=1:   my ($a,$b); () = foo($a,$b,$c)
    # lex=2:   () = foo(my $a,$b,$c)
    for my $lex (0, 1, 2) {
	if ($lex) {
	    next if $keyword =~ /local|our|state|my/;
	}
	my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n    " : "";

	if ($lex == 2) {
	    my $repl = 'my $a';
	    if ($expr =~ 'CORE::do') {
		# do foo() is a syntax error, so B::Deparse emits
		# do (foo()), but does not distinguish between foo and my,
		# because it is too complicated.
		$repl = '(my $a)';
	    }
	    s/\$a/$repl/ for $expr, $expected_expr;
	}

	my $desc = "$keyword: lex=$lex $expr => $expected_expr";
	$desc .= " (lex sub)" if $lexsub;


	my $code_ref;
	if ($lexsub) {
	    package lexsubtest;
	    no warnings 'experimental::lexical_subs';
	    use feature 'lexical_subs';
	    no strict 'vars';
	    $code_ref =
		eval "sub { state sub $keyword; ${vars}() = $expr }"
			    || die "$@ in $expr";
	}
	else {
	    package test;
	    use subs ();
	    import subs $keyword;
	    $code_ref = eval "no strict 'vars'; sub { ${vars}() = $expr }"
			    or die "$@ in $expr";
	}

	my $got_text = $deparse->coderef2text($code_ref);

	unless ($got_text =~ /
    package (?:lexsub)?test;
    BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"}
    use strict 'refs', 'subs';
    use feature [^\n]+
    \Q$vars\E\(\) = (.*)
}/s) {
	    ::fail($desc);
	    ::diag("couldn't extract line from boilerplate\n");
	    ::diag($got_text);
	    return;
	}

	my $got_expr = $1;
	is $got_expr, $expected_expr, $desc;
    }
}


# Deparse can't distinguish 'and' from '&&' etc
my %infix_map = qw(and && or ||);


# test a keyword that is a binary infix operator, like 'cmp'.
# $parens - "$a op $b" is deparsed as "($a op $b)"
# $strong - keyword is strong

sub do_infix_keyword {
    my ($keyword, $parens, $strong) = @_;
    $SEEN_STRENGH{$keyword} = $strong;
    my $expr = "(\$a $keyword \$b)";
    my $nkey = $infix_map{$keyword} // $keyword;
    my $expr = "(\$a $keyword \$b)";
    my $exp = "\$a $nkey \$b";
    $exp = "($exp)" if $parens;
    $exp .= ";";
    # with infix notation, a keyword is always interpreted as core,
    # so no need for Deparse to disambiguate with CORE::
    testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
    testit $keyword, "(\$a $keyword \$b)", $exp;
    testit $keyword, "(\$a CORE::$keyword \$b)", $exp, 1;
    testit $keyword, "(\$a $keyword \$b)", $exp, 1;
    if (!$strong) {
	# B::Deparse fully qualifies any sub whose name is a keyword,
	# imported or not, since the importedness may not be reproduced by
	# the deparsed code.  x is special.
	my $pre = "test::" x ($keyword ne 'x');
	testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);";
    }
    testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1;
}

# test a keyword that is as tandard op/function, like 'index(...)'.
# narg    - how many args to test it with
# $parens - "foo $a, $b" is deparsed as "foo($a, $b)"
# $dollar - an extra '$_' arg will appear in the deparsed output
# $strong - keyword is strong


sub do_std_keyword {
    my ($keyword, $narg, $parens, $dollar, $strong) = @_;

    $SEEN_STRENGH{$keyword} = $strong;

    for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
      for my $lexsub (0,1) { # if true, define lex sub
	my @code;
	for my $do_exp(0, 1) { # first create expr, then expected-expr
	    my @args = map "\$$_", (undef,"a".."z")[1..$narg];
	    push @args, '$_'
		if $dollar && $do_exp && ($strong && !$lexsub or $core);
	    my $args = join(', ', @args);
	     # XXX $lex_parens is temporary, until lex subs are
	     #     deparsed properly.
	    my $lex_parens =
		!$core && $do_exp && $lexsub && $keyword ne 'map';
	    $args = ((!$core && !$strong) || $parens || $lex_parens)
			? "($args)"
			:  @args ? " $args" : "";
	    push @code, (($core && !($do_exp && $strong))
			 ? "CORE::"
			 : $lexsub && $do_exp
			   ? "CORE::" x $core
			   : $do_exp && !$core && !$strong ? "test::" : "")
						       	. "$keyword$args;";
	}
	# code[0]: to run; code[1]: expected
	testit $keyword, @code, $lexsub;
      }
    }
}


while (<DATA>) {
    chomp;
    s/#.*//;
    next unless /\S/;

    my @fields = split;
    die "not 3 fields" unless @fields == 3;
    my ($keyword, $args, $flags) = @fields;

    $args = '012' if $args eq '@';

    my $parens  = $flags =~ s/p//;
    my $invert1 = $flags =~ s/1//;
    my $dollar  = $flags =~ s/\$//;
    my $strong  = $flags =~ s/\+//;
    die "unrecognised flag(s): '$flags'" unless $flags =~ /^-?$/;

    if ($args eq 'B') { # binary infix
	die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar;
	die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1;
	do_infix_keyword($keyword, $parens, $strong);
    }
    else {
	my @narg = split //, $args;
	for my $n (0..$#narg) {
	    my $narg = $narg[$n];
	    my $p = $parens;
	    $p = !$p if ($n == 0 && $invert1);
	    do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong);
	}
    }
}


# Special cases

testit dbmopen  => 'CORE::dbmopen(%foo, $bar, $baz);';
testit dbmclose => 'CORE::dbmclose %foo;';

testit delete   => 'CORE::delete $h{\'foo\'};', 'delete $h{\'foo\'};';
testit delete   => 'CORE::delete $h{\'foo\'};', undef, 1;
testit delete   => 'CORE::delete @h{\'foo\'};', undef, 1;
testit delete   => 'CORE::delete $h[0];', undef, 1;
testit delete   => 'CORE::delete @h[0];', undef, 1;
testit delete   => 'delete $h{\'foo\'};',       'delete $h{\'foo\'};';

# do is listed as strong, but only do { block } is strong;
# do $file is weak,  so test it separately here
testit do       => 'CORE::do $a;';
testit do       => 'do $a;',                    'test::do($a);';
testit do       => 'CORE::do { 1 }',
		   "do {\n        1\n    };";
testit do       => 'CORE::do { 1 }',
		   "CORE::do {\n        1\n    };", 1;
testit do       => 'do { 1 };',
		   "do {\n        1\n    };";

testit each     => 'CORE::each %bar;';

testit eof      => 'CORE::eof();';

testit exists   => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
testit exists   => 'CORE::exists $h{\'foo\'};', undef, 1;
testit exists   => 'CORE::exists &foo;', undef, 1;
testit exists   => 'CORE::exists $h[0];', undef, 1;
testit exists   => 'exists $h{\'foo\'};',       'exists $h{\'foo\'};';

testit exec     => 'CORE::exec($foo $bar);';

testit glob     => 'glob;',                       'glob($_);';
testit glob     => 'CORE::glob;',                 'CORE::glob($_);';
testit glob     => 'glob $a;',                    'glob($a);';
testit glob     => 'CORE::glob $a;',              'CORE::glob($a);';

testit grep     => 'CORE::grep { $a } $b, $c',    'grep({$a;} $b, $c);';

testit keys     => 'CORE::keys %bar;';

testit map      => 'CORE::map { $a } $b, $c',    'map({$a;} $b, $c);';

testit not      => '3 unless CORE::not $a && $b;';

testit readline => 'CORE::readline $a . $b;';

testit readpipe => 'CORE::readpipe $a + $b;';

testit reverse  => 'CORE::reverse sort(@foo);';

# note that the test does '() = split...' which is why the
# limit is optimised to 1
testit split    => 'split;',                     q{split(' ', $_, 1);};
testit split    => 'CORE::split;',               q{split(' ', $_, 1);};
testit split    => 'split $a;',                  q{split(/$a/u, $_, 1);};
testit split    => 'CORE::split $a;',            q{split(/$a/u, $_, 1);};
testit split    => 'split $a, $b;',              q{split(/$a/u, $b, 1);};
testit split    => 'CORE::split $a, $b;',        q{split(/$a/u, $b, 1);};
testit split    => 'split $a, $b, $c;',          q{split(/$a/u, $b, $c);};
testit split    => 'CORE::split $a, $b, $c;',    q{split(/$a/u, $b, $c);};

testit sub      => 'CORE::sub { $a, $b }',
			"sub {\n        \$a, \$b;\n    }\n    ;";

testit system   => 'CORE::system($foo $bar);';

testit values   => 'CORE::values %bar;';


# XXX These are deparsed wrapped in parens.
# whether they should be, I don't know!

testit dump     => '(CORE::dump);';
testit dump     => '(CORE::dump FOO);';
testit goto     => '(CORE::goto);',     '(goto);';
testit goto     => '(CORE::goto FOO);', '(goto FOO);';
testit last     => '(CORE::last);',     '(last);';
testit last     => '(CORE::last FOO);', '(last FOO);';
testit next     => '(CORE::next);',     '(next);';
testit next     => '(CORE::next FOO);', '(next FOO);';
testit redo     => '(CORE::redo);',     '(redo);';
testit redo     => '(CORE::redo FOO);', '(redo FOO);';
testit redo     => '(CORE::redo);',     '(redo);';
testit redo     => '(CORE::redo FOO);', '(redo FOO);';
testit return   => '(return);',         '(return);';
testit return   => '(CORE::return);',   '(return);';

# these are the keywords I couldn't think how to test within this framework

my %not_tested = map { $_ => 1} qw(
    __DATA__
    __END__
    __FILE__
    __LINE__
    __PACKAGE__
    AUTOLOAD
    BEGIN
    CHECK
    CORE
    DESTROY
    END
    INIT
    UNITCHECK
    default
    else
    elsif
    for
    foreach
    format
    given
    if
    m
    no
    package
    q
    qq
    qr
    qw
    qx
    require
    s
    tr
    unless
    until
    use
    when
    while
    y
);


# Sanity check against keyword data:
# make sure we haven't missed any keywords,
# and that we got the strength right.

SKIP:
{
    skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
    my $count = 0;
    my $file = '../regen/keywords.pl';
    my $pass = 1;
    if (open my $fh, '<', $file) {
	while (<$fh>) {
	    last if /^__END__$/;
	}
	while (<$fh>) {
	    next unless /^([+\-])(\w+)$/;
	    my ($strength, $key) = ($1, $2);
	    $strength = ($strength eq '+') ? 1 : 0;
	    $count++;
	    if (!$SEEN{$key} && !$not_tested{$key}) {
		diag("keyword '$key' seen in $file, but not tested here!!");
		$pass = 0;
	    }
	    if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) {
		diag("keyword '$key' strengh as seen in $file doen't match here!!");
		$pass = 0;
	    }
	}
    }
    else {
	diag("Can't open $file: $!");
	$pass = 0;
    }
    # insanity check
    if ($count < 200) {
	diag("Saw $count keywords: less than 200!");
	$pass = 0;
    }
    ok($pass, "sanity checks");
}


__DATA__
#
# format:
#   keyword args flags
#
# args consists of:
#  * one of more digits indictating which lengths of args the function accepts,
#  * or 'B' to indiate a binary infix operator,
#  * or '@' to indicate a list function.
#
# Flags consists of the following (or '-' if no flags):
#    + : strong keyword: can't be overrriden
#    p : the args are parenthesised on deparsing;
#    1 : parenthesising of 1st arg length is inverted
#        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
#    $ : on the first argument length, there is an implicit extra
#        '$_' arg which will appear on deparsing;
#        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
#                     and deparsed as: foo(a1, $_); foo(a1,a2);
#
# XXX Note that we really should get this data from regen/keywords.pl
# and regen/opcodes (augmented if necessary), rather than duplicating it
# here.

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