Deparse with CORE:: to avoid lex sub conflicts
authorFather Chrysostomos <sprout@cpan.org>
Mon, 6 Oct 2014 05:32:23 +0000 (22:32 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 6 Oct 2014 05:32:23 +0000 (22:32 -0700)
If a lexical sub with the same name as a keyword is in scope, we need
to deparse the keyword with a CORE:: prefix.

This commit handles most of the cases, but there are a few exceptional
cases remaining.

lib/B/Deparse-core.t
lib/B/Deparse.pm

index 88ea662..c624218 100644 (file)
@@ -36,7 +36,7 @@ BEGIN {
 
 use strict;
 use Test::More;
-plan tests => 2071;
+plan tests => 4018;
 
 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                     # logic to add CORE::
@@ -51,7 +51,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,7 +68,8 @@ sub testit {
 
        if ($lex == 2) {
            my $repl = 'my $a';
-           if ($expr =~ /\bmap\(\$a|CORE::(chomp|chop|lstat|stat)\b/) {
+           if ($expr =~ /CORE::(chomp|chop|lstat|stat)\b/
+            or $expr =~ ($lexsub ? qr/::map\(\$a/ : qr/\bmap\(\$a/)) {
                # for some reason only these do:
                #  'foo my $a, $b,' => foo my($a), $b, ...
                #  the rest don't parenthesize the my var.
@@ -78,10 +79,20 @@ sub testit {
        }
 
        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;
@@ -92,7 +103,7 @@ sub testit {
        my $got_text = $deparse->coderef2text($code_ref);
 
        unless ($got_text =~ /^\{
-    package test;
+    package (?:lexsub)?test;
     BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"}
     use strict 'refs', 'subs';
     use feature [^\n]+
@@ -131,6 +142,8 @@ 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
@@ -138,6 +151,7 @@ sub do_infix_keyword {
        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 +167,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 +235,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,6 +247,8 @@ 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    };";
 
@@ -227,6 +257,9 @@ testit each     => 'CORE::each %bar;';
 testit eof      => 'CORE::eof();';
 
 testit exists   => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
+testit exists   => 'CORE::exists $h{\'foo\'};', undef, 1;
+testit exists   => 'CORE::exists &foo;', undef, 1;
+testit exists   => 'CORE::exists $h[0];', undef, 1;
 testit exists   => 'exists $h{\'foo\'};',       'exists $h{\'foo\'};';
 
 testit exec     => 'CORE::exec($foo $bar);';
index 424e248..b84217d 100644 (file)
@@ -1222,7 +1222,7 @@ sub maybe_local {
        my @our_local;
        push @our_local, "local" if $priv & OPpLVAL_INTRO;
        push @our_local, "our"   if $priv & $our_intro;
-       my $our_local = join " ", @our_local;
+       my $our_local = join " ", map $self->keyword($_), @our_local;
        if( $our_local[-1] eq 'our' ) {
            if ( $text !~ /^\W(\w+::)*\w+\z/
             and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
@@ -1276,9 +1276,8 @@ sub maybe_my {
                   && $op->name =~ /[ah]v\z/
                   && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
-       my $my = $op->private & OPpPAD_STATE
-           ? $self->keyword("state")
-           : "my";
+       my $my =
+           $self->keyword($op->private & OPpPAD_STATE ? "state" : "my");
        if ($padname->FLAGS & SVpad_TYPED) {
            $my .= ' ' . $padname->SvSTASH->NAME;
        }
@@ -1377,7 +1376,10 @@ sub scopeop {
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
        my $body = $self->lineseq($op, 0, @kids);
-       return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
+       return is_lexical_subs(@kids)
+               ? $body
+               : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+                . " {\n\t$body\n\b}";
     } else {
        my $lineseq = $self->lineseq($op, $cx, @kids);
        return (length ($lineseq) ? "$lineseq;" : "");
@@ -1888,6 +1890,9 @@ sub keyword {
     if (exists $feature_keywords{$name}) {
        return "CORE::$name" if not $self->feature_enabled($name);
     }
+    if ($self->lex_in_scope("&$name")) {
+       return "CORE::$name";
+    }
     if ($strong_proto_keywords{$name}
         || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
            && !defined eval{prototype "CORE::$name"})
@@ -2155,17 +2160,18 @@ sub pp_exists {
     my $self = shift;
     my($op, $cx) = @_;
     my $arg;
+    my $name = $self->keyword("exists");
     if ($op->private & OPpEXISTS_SUB) {
        # Checking for the existence of a subroutine
-       return $self->maybe_parens_func("exists",
+       return $self->maybe_parens_func($name,
                                $self->pp_rv2cv($op->first, 16), $cx, 16);
     }
     if ($op->flags & OPf_SPECIAL) {
        # Array element, not hash element
-       return $self->maybe_parens_func("exists",
+       return $self->maybe_parens_func($name,
                                $self->pp_aelem($op->first, 16), $cx, 16);
     }
-    return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+    return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
                                    $cx, 16);
 }
 
@@ -2173,24 +2179,25 @@ sub pp_delete {
     my $self = shift;
     my($op, $cx) = @_;
     my $arg;
+    my $name = $self->keyword("delete");
     if ($op->private & OPpSLICE) {
        if ($op->flags & OPf_SPECIAL) {
            # Deleting from an array, not a hash
-           return $self->maybe_parens_func("delete",
+           return $self->maybe_parens_func($name,
                                        $self->pp_aslice($op->first, 16),
                                        $cx, 16);
        }
-       return $self->maybe_parens_func("delete",
+       return $self->maybe_parens_func($name,
                                        $self->pp_hslice($op->first, 16),
                                        $cx, 16);
     } else {
        if ($op->flags & OPf_SPECIAL) {
            # Deleting from an array, not a hash
-           return $self->maybe_parens_func("delete",
+           return $self->maybe_parens_func($name,
                                        $self->pp_aelem($op->first, 16),
                                        $cx, 16);
        }
-       return $self->maybe_parens_func("delete",
+       return $self->maybe_parens_func($name,
                                        $self->pp_helem($op->first, 16),
                                        $cx, 16);
     }
@@ -2993,7 +3000,8 @@ sub mapop {
        $expr = $self->deparse($kid, 6);
        push @exprs, $expr if defined $expr;
     }
-    return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+    return $self->maybe_parens_func($self->keyword($name),
+                                   $code . join(", ", @exprs), $cx, 5);
 }
 
 sub pp_mapwhile { mapop(@_, "map") }
@@ -3069,6 +3077,7 @@ sub pp_list {
        $type = $newtype;
     }
     $local = "" if $local eq "either"; # no point if it's all undefs
+    $local &&= $self->keyword($local);
     $local .= " $type " if $local && length $type;
     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
     for (; !null($kid); $kid = $kid->sibling) {
@@ -3333,7 +3342,8 @@ sub pp_null {
                                   . $self->deparse($op->first->sibling, 20),
                                   $cx, 20);
     } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
-       return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+       return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+            . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
     } elsif (!null($op->first->sibling) and
             $op->first->sibling->name eq "null" and
             class($op->first->sibling) eq "UNOP" and