X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a958cfbb8cface09cefb76d5846a867ac7c600dd..c4874d8a25094b3c3426b7831ebba86fc934a652:/lib/B/Deparse-core.t diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t index 2446622..6ee935f 100644 --- a/lib/B/Deparse-core.t +++ b/lib/B/Deparse-core.t @@ -4,7 +4,7 @@ # # 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. # @@ -36,11 +36,10 @@ BEGIN { use strict; use Test::More; -plan tests => 2071; +plan tests => 3886; use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature # logic to add CORE:: -no warnings 'experimental::autoderef'; use B::Deparse; my $deparse = new B::Deparse; @@ -51,7 +50,7 @@ my %SEEN_STRENGH; # deparse "() = $expr", and see if it matches $expected_expr sub testit { - my ($keyword, $expr, $expected_expr) = @_; + my ($keyword, $expr, $expected_expr, $lexsub) = @_; $expected_expr //= $expr; $SEEN{$keyword} = 1; @@ -68,36 +67,49 @@ sub testit { 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)'; + 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_ref = eval "no strict 'vars'; sub { ${vars}() = $expr }" + $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 test; - BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"} - use strict 'refs', 'subs'; + unless ($got_text =~ / + package (?:lexsub)?test; +(?: BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\} +)? use strict 'refs', 'subs'; use feature [^\n]+ - \Q$vars\E\(\) = (.*) -}/s) { +(?: (?:CORE::)?state sub \w+; +)? \Q$vars\E\(\) = (.*) +\}/s) { ::fail($desc); ::diag("couldn't extract line from boilerplate\n"); ::diag($got_text); @@ -105,7 +117,8 @@ sub testit { } my $got_expr = $1; - is $got_expr, $expected_expr, $desc; + is $got_expr, $expected_expr, $desc + or ::diag("ORIGINAL CODE:\n$code");; } } @@ -131,13 +144,16 @@ sub do_infix_keyword { # 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. - $keyword =~ s/^(?!x\z)/test::/; - testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);"; + 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(...)'. @@ -153,20 +169,30 @@ sub do_std_keyword { $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 || $core); + push @args, '$_' + if $dollar && $do_exp && ($strong && !$lexsub or $core); my $args = join(', ', @args); - $args = ((!$core && !$strong) || $parens) + # 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::" + ? "CORE::" + : $lexsub && $do_exp + ? "CORE::" x $core : $do_exp && !$core && !$strong ? "test::" : "") . "$keyword$args;"; } - testit $keyword, @code; # code[0]: to run; code[1]: expected + # code[0]: to run; code[1]: expected + testit $keyword, @code, $lexsub; + } } } @@ -211,6 +237,10 @@ 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; @@ -219,14 +249,20 @@ 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);'; @@ -239,17 +275,32 @@ 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);}; @@ -266,7 +317,12 @@ testit sub => 'CORE::sub { $a, $b }', 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. @@ -431,7 +487,7 @@ defined 01 $+ die @ p1 # do handled specially # dump handled specially -each 1 - # also tested specially +# each handled specially endgrent 0 - endhostent 0 - endnetent 0 - @@ -489,8 +545,8 @@ hex 01 $ index 23 p int 01 $ ioctl 3 p -join 123 p -keys 1 - # also tested specially +join 13 p +# keys handled specially kill 123 p # last handled specially lc 01 $ @@ -523,12 +579,12 @@ ord 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 @@ -569,7 +625,7 @@ setprotoent 1 - 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 @@ -579,14 +635,14 @@ sin 01 $ sleep 01 - socket 4 p socketpair 5 p -sort @ p+ +sort @ p1+ # 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 @@ -610,10 +666,10 @@ umask 01 - 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