[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;
	my $code_ref;
	if ($lexsub) {
	    package lexsubtest;
	    no warnings 'experimental::lexical_subs';
	    use feature 'lexical_subs';
	    no strict 'vars';
            $code = "sub { state sub $keyword; ${vars}() = $expr }";
	    $code_ref = eval $code
			    or die "$@ in $expr";
	}
	else {
	    package test;
	    use subs ();
	    import subs $keyword;
	    $code = "no strict 'vars'; sub { ${vars}() = $expr }";
	    $code_ref = eval $code
			    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]+
(?:    (?:CORE::)?state sub \w+;
)?    \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
            or ::diag("ORIGINAL CODE:\n$code");;
    }
}


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