#
# 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
+# 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.
#
use strict;
use Test::More;
-plan tests => 2071;
use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
# logic to add CORE::
use B::Deparse;
-my $deparse = new B::Deparse;
+my $deparse = B::Deparse->new();
my %SEEN;
-my %SEEN_STRENGH;
+my %SEEN_STRENGTH;
-# for a given keyword, create a sub of that name, then
-# deparse "() = $expr", and see if it matches $expected_expr
+# For a given keyword, create a sub of that name,
+# then deparse 3 different assignment expressions
+# using that keyword. See if the $expr we get back
+# matches $expected_expr.
sub testit {
- my ($keyword, $expr, $expected_expr) = @_;
+ 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 =~ /\bmap\(\$a|CORE::(chomp|chop|lstat|stat)\b/) {
- # for some reason only these do:
- # 'foo my $a, $b,' => foo my($a), $b, ...
- # the rest don't parenthesize the my var.
- $repl = 'my($a)';
- }
- s/\$a/$repl/ for $expr, $expected_expr;
- }
-
- my $desc = "$keyword: lex=$lex $expr => $expected_expr";
-
-
- my $code_ref;
- {
- 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 test;
- use strict 'refs', 'subs';
+ next if ($lex and $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 = "use feature 'isa';\n$code" if $keyword eq "isa";
+ $code = "use feature 'switch';\n$code" if $keyword eq "break";
+ $code_ref = eval $code or die "$@ in $expr";
+ }
+ else {
+ package test;
+ use subs ();
+ import subs $keyword;
+ $code = "no strict 'vars'; sub { ${vars}() = $expr }";
+ $code = "use feature 'isa';\n$code" if $keyword eq "isa";
+ $code = "use feature 'switch';\n$code" if $keyword eq "break";
+ $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]+
- \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;
+(?: (?: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'.
+# 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;
+ $SEEN_STRENGTH{$keyword} = $strong;
my $expr = "(\$a $keyword \$b)";
my $nkey = $infix_map{$keyword} // $keyword;
my $expr = "(\$a $keyword \$b)";
# 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) {
- testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);";
+ # 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
+# Test a keyword that is a standard 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;
+ $SEEN_STRENGTH{$keyword} = $strong;
for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
- 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 || $core);
- my $args = join(', ', @args);
- $args = ((!$core && !$strong) || $parens)
- ? "($args)"
- : @args ? " $args" : "";
- push @code, (($core && !($do_exp && $strong)) ? "CORE::" : "")
- . "$keyword$args;";
- }
- testit $keyword, @code; # code[0]: to run; code[1]: expected
+ 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;
+ }
}
}
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);
+ 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);
- }
+ 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);
+ }
}
}
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;', '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 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 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.
__FILE__
__LINE__
__PACKAGE__
- __SUB__
AUTOLOAD
BEGIN
CHECK
END
INIT
UNITCHECK
+ catch
default
+ defer
else
elsif
+ finally
for
foreach
format
require
s
tr
+ try
unless
until
use
y
);
-
-
# Sanity check against keyword data:
# make sure we haven't missed any keywords,
# and that we got the strength right.
diag("keyword '$key' seen in $file, but not tested here!!");
$pass = 0;
}
- if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) {
+ if (exists $SEEN_STRENGTH{$key} and $SEEN_STRENGTH{$key} != $strength) {
diag("keyword '$key' strengh as seen in $file doen't match here!!");
$pass = 0;
}
ok($pass, "sanity checks");
}
-
+done_testing();
__DATA__
#
die @ p1
# do handled specially
# dump handled specially
-each 1 - # also tested specially
+# each handled specially
endgrent 0 -
endhostent 0 -
endnetent 0 -
index 23 p
int 01 $
ioctl 3 p
-join 123 p
-keys 1 - # also tested specially
+isa B -
+join 13 p
+# keys handled specially
kill 123 p
# last handled specially
lc 01 $
our 123 p+ # skip with 0 args, as our() => ()
pack 123 p
pipe 2 p
-pop 01 1
+pop 0 1 # also tested specially
pos 01 $+
print @ p$+
printf @ p$+
prototype 1 +
-push 123 p
+# push handled specially
quotemeta 01 $
rand 01 -
read 34 p
setpwent 0 -
setservent 1 -
setsockopt 4 p
-shift 01 1
+shift 0 1 # also tested specially
shmctl 3 p
shmget 3 p
shmread 4 p
sleep 01 -
socket 4 p
socketpair 5 p
-sort @ p+
+sort 12 p+
# split handled specially
-splice 12345 p
+# splice handled specially
sprintf 123 p
sqrt 01 $
srand 01 -
stat 01 $
-state 123 p+ # skip with 0 args, as state() => ()
+state 123 p1+ # skip with 0 args, as state() => ()
study 01 $+
# sub handled specially
substr 234 p
undef 01 +
unlink @ p$
unpack 12 p$
-unshift 1 p
+# unshift handled specially
untie 1 -
utime @ p1
-values 1 - # also tested specially
+# values handled specially
vec 3 p
wait 0 -
waitpid 2 p
https://perl5.git.perl.org / perl5.git / blobdiff