Remove fixed bug from Deparse’s docs

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

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 7ea7fc1..81c918c 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -26,7 +26,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
         ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
         ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
-$VERSION = "1.03";
+$VERSION = "1.04";
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -243,7 +243,8 @@ BEGIN {
 #
 # subs_declared
 # keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
+# That means we can omit parentheses from the arguments. It also means we
+# need to put CORE:: on core functions of the same name.
 #
 # subs_deparsed
 # Keeps track of fully qualified names of all deparsed subs.
@@ -1017,12 +1018,13 @@ sub maybe_parens_unop {
        if ($name eq "umask" && $kid =~ /^\d+$/) {
            $kid = sprintf("%#o", $kid);
        }
-       return "$name($kid)";
+       return $self->keyword($name) . "($kid)";
     } else {
        $kid = $self->deparse($kid, 16);
        if ($name eq "umask" && $kid =~ /^\d+$/) {
            $kid = sprintf("%#o", $kid);
        }
+       $name = $self->keyword($name);
        if (substr($kid, 0, 1) eq "\cS") {
            # use kid's parens
            return $name . substr($kid, 1);
@@ -1521,10 +1523,28 @@ sub pp_setstate { pp_nextstate(@_) }
 
 sub pp_unstack { return "" } # see also leaveloop
 
+sub keyword {
+    my $self = shift;
+    my $name = shift;
+    return $name if $name =~ /^CORE::/; # just in case
+    if (
+      $name !~ /^(?:chom?p|exec|system)\z/
+       && !defined eval{prototype "CORE::$name"}
+    ) { return $name }
+    if (
+       exists $self->{subs_declared}{$name}
+        or
+       exists &{"$self->{curstash}::$name"}
+    ) {
+       return "CORE::$name"
+    }
+    return $name;
+}
+
 sub baseop {
     my $self = shift;
     my($op, $cx, $name) = @_;
-    return $name;
+    return $self->keyword($name);
 }
 
 sub pp_stub {
@@ -1600,7 +1620,7 @@ sub pp_not {
     my $self = shift;
     my($op, $cx) = @_;
     if ($cx <= 4) {
-       $self->pfixop($op, $cx, "not ", 4);
+       $self->pfixop($op, $cx, $self->keyword("not")." ", 4);
     } else {
        $self->pfixop($op, $cx, "!", 21);       
     }
@@ -1626,7 +1646,8 @@ sub unop {
 
        return $self->maybe_parens_unop($name, $kid, $cx);
     } else {
-       return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
+       return $self->keyword($name)
+         . ($op->flags & OPf_SPECIAL ? "()" : "");
     }
 }
 
@@ -1659,6 +1680,7 @@ sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
 sub pp_each { unop(@_, "each") }
 sub pp_values { unop(@_, "values") }
 sub pp_keys { unop(@_, "keys") }
+{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
 sub pp_boolkeys { 
     # no name because its an optimisation op that has no keyword
     unop(@_,"");
@@ -1950,7 +1972,7 @@ sub pp_last { loopex(@_, "last") }
 sub pp_next { loopex(@_, "next") }
 sub pp_redo { loopex(@_, "redo") }
 sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
+sub pp_dump { loopex(@_, $_[0]->keyword("dump")) }
 
 sub ftst {
     my $self = shift;
@@ -2283,9 +2305,10 @@ sub listop {
     my(@exprs);
     my $parens = ($cx >= 5) || $self->{'parens'};
     my $kid = $op->first->sibling;
-    return $name if null $kid;
+    return $self->keyword($name) if null $kid;
     my $first;
     $name = "socketpair" if $name eq "sockpair";
+    my $fullname = $self->keyword($name);
     my $proto = prototype("CORE::$name");
     if (defined $proto
        && $proto =~ /^;?\*/
@@ -2309,12 +2332,13 @@ sub listop {
        push @exprs, $self->deparse($kid, 6);
     }
     if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
-       return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
+       return "$exprs[0] = $fullname"
+                . ($parens ? "($exprs[0])" : " $exprs[0]");
     }
     if ($parens) {
-       return "$name(" . join(", ", @exprs) . ")";
+       return "$fullname(" . join(", ", @exprs) . ")";
     } else {
-       return "$name " . join(", ", @exprs);
+       return "$fullname " . join(", ", @exprs);
     }
 }
 
@@ -2404,6 +2428,9 @@ sub pp_syscall { listop(@_, "syscall") }
 sub pp_glob {
     my $self = shift;
     my($op, $cx) = @_;
+    if ($op->flags & OPf_SPECIAL) {
+       return $self->deparse($op->first->sibling);
+    }
     my $text = $self->dq($op->first->sibling);  # skip pushmark
     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
        or $text =~ /[<>]/) {
@@ -2432,10 +2459,11 @@ sub pp_truncate {
         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
     }
     my $len = $self->deparse($kid->sibling, 6);
+    my $name = $self->keyword('truncate');
     if ($parens) {
-       return "truncate($fh, $len)";
+       return "$name($fh, $len)";
     } else {
-       return "truncate $fh, $len";
+       return "$name $fh, $len";
     }
 }
 
@@ -2470,10 +2498,11 @@ sub indirop {
        $expr = $self->deparse($kid, 6);
        push @exprs, $expr;
     }
-    my $name2 = $name;
+    my $name2;
     if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
-       $name2 = 'reverse sort';
+       $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
     }
+    else { $name2 = $self->keyword($name) }
     if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
        return "$exprs[0] = $name2 $indir $exprs[0]";
     }
@@ -3393,15 +3422,7 @@ sub pp_entersub {
            return $prefix . $amper. $kid;
        }
     } else {
-       # glob() invocations can be translated into calls of
-       # CORE::GLOBAL::glob with a second parameter, a number.
-       # Reverse this.
-       if ($kid eq "CORE::GLOBAL::glob") {
-           $kid = "glob";
-           $args =~ s/\s*,[^,]+$//;
-       }
-
-       # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
+       # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
        # so it must have been translated from a keyword call. Translate
        # it back.
        $kid =~ s/^CORE::GLOBAL:://;
@@ -3838,7 +3859,10 @@ sub pp_backtick {
     # skip pushmark if it exists (readpipe() vs ``)
     my $child = $op->first->sibling->isa('B::NULL')
        ? $op->first : $op->first->sibling;
-    return single_delim("qx", '`', $self->dq($child));
+    if ($self->pure_string($child)) {
+       return single_delim("qx", '`', $self->dq($child, 1));
+    }
+    unop($self, @_, "readpipe");
 }
 
 sub dquote {
@@ -4845,14 +4869,6 @@ from the Perl core to fix.
 
 =item *
 
-If a keyword is over-ridden, and your program explicitly calls
-the built-in version by using CORE::keyword, the output of B::Deparse
-will not reflect this. If you run the resulting code, it will call
-the over-ridden version rather than the built-in one. (Maybe there
-should be an option to B<always> print keyword calls as C<CORE::name>.)
-
-=item *
-
 Some constants don't print correctly either with or without B<-d>.
 For instance, neither B::Deparse nor Data::Dumper know how to print
 dual-valued scalars correctly, as in: