[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:: versus 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 => 3886;

use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                    # logic to add CORE::
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;
    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 each     => 'CORE::each @foo;';

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 keys     => 'CORE::keys @bar;';

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

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

testit pop      => 'CORE::pop @foo;';

testit push     => 'CORE::push @foo;',           'CORE::push(@foo);';
testit push     => 'CORE::push @foo, 1;',        'CORE::push(@foo, 1);';
testit push     => 'CORE::push @foo, 1, 2;',     'CORE::push(@foo, 1, 2);';

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

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

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

testit shift    => 'CORE::shift @foo;';

testit splice   => q{CORE::splice @foo;},                 q{CORE::splice(@foo);};
testit splice   => q{CORE::splice @foo, 0;},              q{CORE::splice(@foo, 0);};
testit splice   => q{CORE::splice @foo, 0, 1;},           q{CORE::splice(@foo, 0, 1);};
testit splice   => q{CORE::splice @foo, 0, 1, 'a';},      q{CORE::splice(@foo, 0, 1, 'a');};
testit splice   => q{CORE::splice @foo, 0, 1, 'a', 'b';}, q{CORE::splice(@foo, 0, 1, 'a', 'b');};

# 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 unshift  => 'CORE::unshift @foo;',        'CORE::unshift(@foo);';
testit unshift  => 'CORE::unshift @foo, 1;',     'CORE::unshift(@foo, 1);';
testit unshift  => 'CORE::unshift @foo, 1, 2;',  'CORE::unshift(@foo, 1, 2);';

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


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