Finish deparsing ‘my sub if; CORE::if...’
authorFather Chrysostomos <sprout@cpan.org>
Tue, 7 Oct 2014 01:46:54 +0000 (18:46 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 7 Oct 2014 02:27:43 +0000 (19:27 -0700)
Commit 3188a8216 took care of the majority of cases making mostly gen-
eral changes.

This commit finishes up all the weird keywords that need spe-
cial handling.

lib/B/Deparse.pm
lib/B/Deparse.t

index d5f290e..ed10826 100644 (file)
@@ -462,7 +462,7 @@ sub next_todo {
     my $gv = $cv->GV;
     my $name = $self->gv_name($gv);
     if ($ent->[2]) {
-       return "format $name =\n"
+       return $self->keyword("format") . " $name =\n"
            . $self->deparse_format($ent->[1]). "\n";
     } else {
        $self->{'subs_declared'}{$name} = 1;
@@ -470,6 +470,7 @@ sub next_todo {
            my $use_dec = $self->begin_is_use($cv);
            if (defined ($use_dec) and $self->{'expand'} < 5) {
                return () if 0 == length($use_dec);
+               $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
                return $use_dec;
            }
        }
@@ -483,13 +484,14 @@ sub next_todo {
        if (class($cv->STASH) ne "SPECIAL") {
            my $stash = $cv->STASH->NAME;
            if ($stash ne $self->{'curstash'}) {
-               $p = "package $stash;\n";
+               $p = $self->keyword("package") . " $stash;\n";
                $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
                $self->{'curstash'} = $stash;
            }
            $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
        }
-        return "${p}${l}sub $name " . $self->deparse_sub($cv);
+        return "${p}${l}" . $self->keyword("sub") . " $name "
+             . $self->deparse_sub($cv);
     }
 }
 
@@ -820,9 +822,9 @@ sub compile {
        my $laststash = defined $self->{'curcop'}
            ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
        if (defined *{$laststash."::DATA"}{IO}) {
-           print "package $laststash;\n"
+           print $self->keyword("package") . " $laststash;\n"
                unless $laststash eq $self->{'curstash'};
-           print "__DATA__\n";
+           print $self->keyword("__DATA__") . "\n";
            print readline(*{$laststash."::DATA"});
        }
     }
@@ -1356,11 +1358,12 @@ sub scopeop {
            my $top = $kid->first;
            my $name = $top->name;
            if ($name eq "and") {
-               $name = "while";
+               $name = $self->keyword("while");
            } elsif ($name eq "or") {
-               $name = "until";
+               $name = $self->keyword("until");
            } else { # no conditional -> while 1 or until 0
-               return $self->deparse($top->first, 1) . " while 1";
+               return $self->deparse($top->first, 1) . " "
+                    . $self->keyword("while") . " 1";
            }
            my $cond = $top->first;
            my $body = $cond->sibling->first; # skip lineseq
@@ -1510,7 +1513,7 @@ sub stash_variable_name {
        return $name, 0; # not quoted
     }
     else {
-       single_delim("q", "'", $name), 1;
+       single_delim("q", "'", $name, $self), 1;
     }
 }
 
@@ -1651,7 +1654,7 @@ sub pp_nextstate {
     push @text, $self->cop_subs($op);
     my $stash = $op->stashpv;
     if ($stash ne $self->{'curstash'}) {
-       push @text, "package $stash;\n";
+       push @text, $self->keyword("package") . " $stash;\n";
        $self->{'curstash'} = $stash;
     }
 
@@ -1677,14 +1680,15 @@ sub pp_nextstate {
 
     if (defined ($warning_bits) and
        !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
-       push @text, declare_warnings($self->{'warnings'}, $warning_bits);
+       push @text,
+           $self->declare_warnings($self->{'warnings'}, $warning_bits);
        $self->{'warnings'} = $warning_bits;
     }
 
     my $hints = $] < 5.008009 ? $op->private : $op->hints;
     my $old_hints = $self->{'hints'};
     if ($self->{'hints'} != $hints) {
-       push @text, declare_hints($self->{'hints'}, $hints);
+       push @text, $self->declare_hints($self->{'hints'}, $hints);
        $self->{'hints'} = $hints;
     }
 
@@ -1711,14 +1715,15 @@ sub pp_nextstate {
                my $bundle =
                    $feature::hint_bundles[$to >> $feature::hint_shift];
                $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
-               push @text, "no feature;\n",
-                           "use feature ':$bundle';\n";
+               push @text,
+                   $self->keyword("no") . " feature;\n",
+                   $self->keyword("use") . " feature ':$bundle';\n";
            }
        }
     }
 
     if ($] > 5.009) {
-       push @text, declare_hinthash(
+       push @text, $self->declare_hinthash(
            $self->{'hinthash'}, $newhh,
            $self->{indent_size}, $self->{hints},
        );
@@ -1739,26 +1744,26 @@ sub pp_nextstate {
 }
 
 sub declare_warnings {
-    my ($from, $to) = @_;
+    my ($self, $from, $to) = @_;
     if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
-       return "use warnings;\n";
+       return $self->keyword("use") . " warnings;\n";
     }
     elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
-       return "no warnings;\n";
+       return $self->keyword("no") . " warnings;\n";
     }
     return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
 }
 
 sub declare_hints {
-    my ($from, $to) = @_;
+    my ($self, $from, $to) = @_;
     my $use = $to   & ~$from;
     my $no  = $from & ~$to;
     my $decls = "";
     for my $pragma (hint_pragmas($use)) {
-       $decls .= "use $pragma;\n";
+       $decls .= $self->keyword("use") . " $pragma;\n";
     }
     for my $pragma (hint_pragmas($no)) {
-        $decls .= "no $pragma;\n";
+        $decls .= $self->keyword("no") . " $pragma;\n";
     }
     return $decls;
 }
@@ -1777,7 +1782,7 @@ my %ignored_hints = (
 my %rev_feature;
 
 sub declare_hinthash {
-    my ($from, $to, $indent, $hints) = @_;
+    my ($self, $from, $to, $indent, $hints) = @_;
     my $doing_features =
        ($hints & $feature::hint_mask) == $feature::hint_mask;
     my @decls;
@@ -1790,10 +1795,10 @@ sub declare_hinthash {
        if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
            push(@features, $key), next if $is_feature;
            push @decls,
-               qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
+               qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
              . (
                   defined $to->{$key}
-                       ? single_delim("q", "'", $to->{$key})
+                       ? single_delim("q", "'", $to->{$key}, $self)
                        : 'undef'
                )
              . qq(;);
@@ -1813,11 +1818,11 @@ sub declare_hinthash {
        if (!%rev_feature) { %rev_feature = reverse %feature::feature }
     }
     if (@features) {
-       push @ret, "use feature "
+       push @ret, $self->keyword("use") . " feature "
                 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
     }
     if (@unfeatures) {
-       push @ret, "no feature "
+       push @ret, $self->keyword("no") . " feature "
                 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
                 . ";\n";
     }
@@ -1890,7 +1895,17 @@ sub keyword {
     if (exists $feature_keywords{$name}) {
        return "CORE::$name" if not $self->feature_enabled($name);
     }
-    if ($self->lex_in_scope("&$name")) {
+    # This sub may be called for a program that has no nextstate ops.  In
+    # that case we may have a lexical sub named no/use/sub in scope but
+    # but $self->lex_in_scope will return false because it depends on the
+    # current nextstate op.  So we need this alternate method if there is
+    # no current cop.
+    if (!$self->{'curcop'}) {
+       $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+       return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
+                            || exists $self->{'curcvlex'}{"o&$name"};
+    } elsif ($self->lex_in_scope("&$name")
+         || $self->lex_in_scope("&$name", 1)) {
        return "CORE::$name";
     }
     if ($strong_proto_keywords{$name}
@@ -2302,7 +2317,7 @@ sub pp_refgen {
 sub e_anoncode {
     my ($self, $info) = @_;
     my $text = $self->deparse_sub($info->{code});
-    return "sub " . $text;
+    return $self->keyword("sub") . " $text";
 }
 
 sub pp_srefgen { pp_refgen(@_) }
@@ -2649,6 +2664,7 @@ sub logop {
     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
     my $left = $op->first;
     my $right = $op->first->sibling;
+    $blockname &&= $self->keyword($blockname);
     if ($cx < 1 and is_scope($right) and $blockname
        and $self->{'expand'} < 7)
     { # if ($a) {$b}
@@ -3127,8 +3143,9 @@ sub pp_cond_expr {
 
     $cond = $self->deparse($cond, 1);
     $true = $self->deparse($true, 0);
-    my $head = "if ($cond) {\n\t$true\n\b}";
+    my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
     my @elsifs;
+    my $elsif;
     while (!null($false) and is_ifelse_cont($false)) {
        my $newop = $false->first;
        my $newcond = $newop->first;
@@ -3142,10 +3159,11 @@ sub pp_cond_expr {
        }
        $newcond = $self->deparse($newcond, 1);
        $newtrue = $self->deparse($newtrue, 0);
-       push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+       $elsif ||= $self->keyword("elsif");
+       push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
     }
     if (!null($false)) {
-       $false = $cuddle . "else {\n\t" .
+       $false = $cuddle . $self->keyword("else") . " {\n\t" .
          $self->deparse($false, 0) . "\n\b}\cK";
     } else {
        $false = "\cK";
@@ -3211,7 +3229,8 @@ sub loop_common {
        if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
            confess unless $var eq '$_';
            $body = $body->first;
-           return $self->deparse($body, 2) . " foreach ($ary)";
+           return $self->deparse($body, 2) . " "
+                . $self->keyword("foreach") . " ($ary)";
        }
        $head = "foreach $var ($ary) ";
     } elsif ($kid->name eq "null") { # while/until
@@ -3274,6 +3293,7 @@ sub loop_common {
        ref $cond and $cond = $self->deparse($cond, 1);
        $head = "$name ($cond) ";
     }
+    $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
     $body =~ s/;?$/;\n/;
 
     return $head . "{\n\t" . $body . "\b}" . $cont;
@@ -3912,7 +3932,7 @@ sub pp_entersub {
                $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
              }
              if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
-               $kid = single_delim("q", "'", $kid) . '->';
+               $kid = single_delim("q", "'", $kid, $self) . '->';
              }
            }
        }
@@ -4172,21 +4192,22 @@ sub balanced_delim {
 }
 
 sub single_delim {
-    my($q, $default, $str) = @_;
+    my($q, $default, $str, $self) = @_;
     return "$default$str$default" if $default and index($str, $default) == -1;
+    my $coreq = $self->keyword($q); # maybe CORE::q
     if ($q ne 'qr') {
        (my $succeed, $str) = balanced_delim($str);
-       return "$q$str" if $succeed;
+       return "$coreq$str" if $succeed;
     }
     for my $delim ('/', '"', '#') {
-       return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+       return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
     }
     if ($default) {
        $str =~ s/$default/\\$default/g;
        return "$default$str$default";
     } else {
        $str =~ s[/][\\/]g;
-       return "$q/$str/";
+       return "$coreq/$str/";
     }
 }
 
@@ -4313,7 +4334,7 @@ sub const {
            for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
                if ($mg->TYPE eq 'r') {
                    my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
-                   return single_delim("qr", "", $re);
+                   return single_delim("qr", "", $re, $self);
                }
            }
        }
@@ -4326,9 +4347,10 @@ sub const {
     } elsif ($sv->FLAGS & SVf_POK) {
        my $str = $sv->PV;
        if ($str =~ /[[:^print:]]/) {
-           return single_delim("qq", '"', uninterp escape_str unback $str);
+           return single_delim("qq", '"',
+                                uninterp(escape_str unback $str), $self);
        } else {
-           return single_delim("q", "'", unback $str);
+           return single_delim("q", "'", unback($str), $self);
        }
     } else {
        return "undef";
@@ -4424,7 +4446,7 @@ sub pp_backtick {
     my $child = $op->first->sibling->isa('B::NULL')
        ? $op->first : $op->first->sibling;
     if ($self->pure_string($child)) {
-       return single_delim("qx", '`', $self->dq($child, 1));
+       return single_delim("qx", '`', $self->dq($child, 1), $self);
     }
     unop($self, @_, "readpipe");
 }
@@ -4435,7 +4457,8 @@ sub dquote {
     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
     return $self->deparse($kid, $cx) if $self->{'unquote'};
     $self->maybe_targmy($kid, $cx,
-                       sub {single_delim("qq", '"', $self->dq($_[1]))});
+                       sub {single_delim("qq", '"', $self->dq($_[1]),
+                                          $self)});
 }
 
 # OP_STRINGIFY is a listop, but it only ever has one arg
@@ -4690,7 +4713,7 @@ sub pp_trans {
     $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
     $to = "" if $from eq $to and $flags eq "";
     $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
-    return "tr" . double_delim($from, $to) . $flags;
+    return $self->keyword("tr") . double_delim($from, $to) . $flags;
 }
 
 sub pp_transr { &pp_trans . 'r' }
@@ -4897,9 +4920,9 @@ sub matchop {
     $flags = $matchwords{$flags} if $matchwords{$flags};
     if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
        $re =~ s/\?/\\?/g;
-       $re = "m?$re?";        # explicit 'm' is required
+       $re = $self->keyword("m") . "?$re?";     # explicit 'm' is required
     } elsif ($quote) {
-       $re = single_delim($name, $delim, $re);
+       $re = single_delim($name, $delim, $re, $self);
     }
     $re = $re . $flags if $quote;
     if ($binop) {
@@ -5028,12 +5051,13 @@ sub pp_subst {
     $flags .= $self->re_flags($op);
     $flags = join '', sort split //, $flags;
     $flags = $substwords{$flags} if $substwords{$flags};
+    my $core_s = $self->keyword("s"); # maybe CORE::s
     if ($binop) {
-       return $self->maybe_parens("$var =~ s"
+       return $self->maybe_parens("$var =~ $core_s"
                                   . double_delim($re, $repl) . $flags,
                                   $cx, 20);
     } else {
-       return "s". double_delim($re, $repl) . $flags;  
+       return "$core_s". double_delim($re, $repl) . $flags;    
     }
 }
 
index ef238bf..3a8e074 100644 (file)
@@ -13,7 +13,7 @@ use warnings;
 use strict;
 use Test::More;
 
-my $tests = 21; # not counting those in the __DATA__ section
+my $tests = 25; # not counting those in the __DATA__ section
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -270,6 +270,11 @@ x(); z()
 .
 EOCODH
 
+# CORE::format
+$a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
+             .qq` my sub format; CORE::format =" -e. 2>&1`;
+like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');
+
 # literal big chars under 'use utf8'
 is($deparse->coderef2text(sub{ use utf8; /€/; }),
 '{
@@ -285,6 +290,25 @@ is($a, <<'EOCODI', 'no extra output when deparsing foo()');
 foo();
 EOCODI
 
+# CORE::no
+$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
+             .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
+like($a, qr/my sub no;\n\(\);\nCORE::no less;/,
+    'CORE::no after my sub no');
+
+# CORE::use
+$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
+             .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
+like($a, qr/my sub use;\n\(\);\nCORE::use less;/,
+    'CORE::use after my sub use');
+
+# CORE::__DATA__
+$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
+             .qq`"use feature q|:all|; my sub __DATA__; `
+             .qq`CORE::__DATA__" 2>&1`;
+like($a, qr/my sub __DATA__;\n\(\);\nCORE::__DATA__/,
+    'CORE::__DATA__ after my sub __DATA__');
+
 
 done_testing($tests);
 
@@ -1106,6 +1130,58 @@ CORE::given ($x) {
 CORE::evalbytes '';
 () = CORE::__SUB__;
 ####
+# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
+# lexical subroutines and keywords of the same name
+# CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
+my sub default;
+my sub else;
+my sub elsif;
+my sub for;
+my sub foreach;
+my sub given;
+my sub if;
+my sub m;
+my sub no;
+my sub package;
+my sub q;
+my sub qq;
+my sub qr;
+my sub qx;
+my sub require;
+my sub s;
+my sub sub;
+my sub tr;
+my sub unless;
+my sub until;
+my sub use;
+my sub when;
+my sub while;
+CORE::default { die; }
+CORE::if ($1) { die; }
+CORE::if ($1) { die; }
+CORE::elsif ($1) { die; }
+CORE::else { die; }
+CORE::for (die; $1; die) { die; }
+CORE::foreach $_ (1 .. 10) { die; }
+die CORE::foreach (1);
+CORE::given ($1) { die; }
+CORE::m[/];
+CORE::m?/?;
+CORE::package foo;
+CORE::no strict;
+() = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]);
+CORE::require 1;
+CORE::s///;
+() = CORE::sub { die; } ;
+CORE::tr///;
+CORE::unless ($1) { die; }
+CORE::until ($1) { die; }
+die CORE::until $1;
+CORE::use strict;
+CORE::when ($1 ~~ $2) { die; }
+CORE::while ($1) { die; }
+die CORE::while $1;
+####
 # Feature hints
 use feature 'current_sub', 'evalbytes';
 print;