Deparse: handle some strong keywords better

[perl5.git] / dist / B-Deparse / Deparse.pm

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 63a3259..1dc1ef4 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
          CVf_METHOD CVf_LVALUE
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = '1.14';
+$VERSION = '1.18';
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -301,6 +301,7 @@ BEGIN {
 #  1             statement modifiers
 #  0.5           statements, but still print scopes as do { ... }
 #  0             statement level
+# -1             format body
 
 # Nonprinting characters with special meaning:
 # \cS - steal parens (see maybe_parens_unop)
@@ -895,7 +896,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
            for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
                push @ops, $o;
            }
-           $body = $self->lineseq(undef, @ops).";";
+           $body = $self->lineseq(undef, 0, @ops).";";
            my $scope_en = $self->find_scope_en($lineseq);
            if (defined $scope_en) {
                my $subs = join"", $self->seq_subs($scope_en);
@@ -939,7 +940,8 @@ sub deparse_format {
        push @text, "\f".$self->const_sv($kid)->PV;
        $kid = $kid->sibling;
        for (; not null $kid; $kid = $kid->sibling) {
-           push @exprs, $self->deparse($kid, 0);
+           push @exprs, $self->deparse($kid, -1);
+           $exprs[-1] =~ s/;\z//;
        }
        push @text, "\f".join(", ", @exprs)."\n" if @exprs;
        $op = $op->sibling;
@@ -1139,7 +1141,7 @@ sub DESTROY {}    #       Do not AUTOLOAD
 # any subroutine declarations to the deparsed ops, otherwise we
 # append appropriate declarations.
 sub lineseq {
-    my($self, $root, @ops) = @_;
+    my($self, $root, $cx, @ops) = @_;
     my($expr, @exprs);
 
     my $out_cop = $self->{'curcop'};
@@ -1160,12 +1162,13 @@ sub lineseq {
     $self->walk_lineseq($root, \@ops,
                       sub { push @exprs, $_[0]} );
 
-    my $body = join(";\n", grep {length} @exprs);
+    my $sep = $cx ? '; ' : ";\n";
+    my $body = join($sep, grep {length} @exprs);
     my $subs = "";
     if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
        $subs = join "\n", $self->seq_subs($limit_seq);
     }
-    return join(";\n", grep {length} $body, $subs);
+    return join($sep, grep {length} $body, $subs);
 }
 
 sub scopeop {
@@ -1200,9 +1203,9 @@ sub scopeop {
        push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-       return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
+       return "do {\n\t" . $self->lineseq($op, 0, @kids) . "\n\b}";
     } else {
-       my $lineseq = $self->lineseq($op, @kids);
+       my $lineseq = $self->lineseq($op, $cx, @kids);
        return (length ($lineseq) ? "$lineseq;" : "");
     }
 }
@@ -1678,6 +1681,17 @@ my %feature_keywords = (
    fc       => 'fc',
 );
 
+# keywords that are strong and also have a prototype
+#
+my %strong_proto_keywords = map { $_ => 1 } qw(
+    glob
+    pos
+    prototype
+    scalar
+    study
+    undef
+);
+
 sub keyword {
     my $self = shift;
     my $name = shift;
@@ -1693,9 +1707,9 @@ sub keyword {
         if !$hh
         || !$hh->{"feature_$feature_keywords{$name}"}
     }
-    if (
-      $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
-       && !defined eval{prototype "CORE::$name"}
+    if ($strong_proto_keywords{$name}
+        || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
+           && !defined eval{prototype "CORE::$name"})
     ) { return $name }
     if (
        exists $self->{subs_declared}{$name}
@@ -2155,10 +2169,10 @@ sub loopex {
     } elsif (class($op) eq "OP") {
        # no-op
     } elsif (class($op) eq "UNOP") {
-       (my $kid = $self->deparse($op->first, 5)) =~ s/^\cS//;
+       (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
        $name .= " $kid";
     }
-    return $self->maybe_parens($name, $cx, 5);
+    return $self->maybe_parens($name, $cx, 7);
 }
 
 sub pp_last { loopex(@_, "last") }
@@ -2500,7 +2514,7 @@ sub rv2gv_or_string {
     my($self,$op) = @_;
     if ($op->name eq "gv") { # could be open("open") or open("###")
        my($name,$quoted) =
-           $self->stash_variable_name(undef,$self->gv_or_padgv($op));
+           $self->stash_variable_name("", $self->gv_or_padgv($op));
        $quoted ? $name : "*$name";
     }
     else {
@@ -2750,6 +2764,7 @@ sub indirop {
        }
     } elsif (
        !$indir && $name eq "sort"
+      && !null($op->first->sibling)
       && $op->first->sibling->name eq 'entersub'
     ) {
        # We cannot say sort foo(bar), as foo will be interpreted as a
@@ -3011,7 +3026,7 @@ sub loop_common {
        for (; $$state != $$cont; $state = $state->sibling) {
            push @states, $state;
        }
-       $body = $self->lineseq(undef, @states);
+       $body = $self->lineseq(undef, 0, @states);
        if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
            $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
            $cont = "\cK";
@@ -4587,7 +4602,10 @@ sub matchop {
        carp("found ".$kid->name." where regcomp expected");
     } else {
        ($re, $quote) = $self->regcomp($kid, 21, $extended);
-       my $matchop = $kid->first->first;
+       my $matchop = $kid->first;
+       if ($matchop->name eq 'regcrest') {
+           $matchop = $matchop->first;
+       }
        if ($matchop->name =~ /^(?:match|transr?|subst)\z/
           && $matchop->flags & OPf_SPECIAL) {
            $rhs_bound_to_defsv = 1;
@@ -4651,8 +4669,11 @@ sub pp_split {
 
     # handle special case of split(), and split(' ') that compiles to /\s+/
     # Under 5.10, the reflags may be undef if the split regexp isn't a constant
+    # Under 5.17.5+, the special flag is on split itself.
     $kid = $op->first;
-    if ( $kid->flags & OPf_SPECIAL
+    if ( $op->flags & OPf_SPECIAL
+       or
+        $kid->flags & OPf_SPECIAL
         and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
              : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
        $exprs[0] = "' '";