This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[perl #91008] Deparse doesn't like each $ref
[perl5.git] / dist / B-Deparse / Deparse.pm
diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 61fe293..be2406f 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -11,34 +11,42 @@ package B::Deparse;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
-        OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
+        OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
         OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
         OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
         OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
         OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
         OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
         OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
-        OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
-        OPpREVERSE_INPLACE OPpCONST_NOVER
+        OPpSORT_REVERSE
         SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
          CVf_METHOD CVf_LVALUE
         SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
          CVf_METHOD CVf_LVALUE
-        PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_NONDESTRUCT
+        PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
-        ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
-        ($] < 5.011 ? 'CVf_LOCKED' : ());
-$VERSION = 0.97;
+        ($] < 5.008004 ? () : 'OPpSORT_INPLACE'),
+        ($] < 5.008006 ? () : qw(OPpSORT_DESCEND OPpITER_REVERSED)),
+        ($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
+        ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
+        ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
+        ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
+$VERSION = "1.04";
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
 
 BEGIN {
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
 
 BEGIN {
-    # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
-    # be to fake up a dummy CVf_LOCKED that will never actually be true.
-    *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
+    # Easiest way to keep this code portable between version looks to
+    # be to fake up a dummy constant that will never actually be true.
+    foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
+               OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
+               PMf_NONDESTRUCT)) {
+       no strict 'refs';
+       *{$_} = sub () {0} unless *{$_}{CODE};
+    }
 }
 
 # Changes between 0.50 and 0.51:
 # - fixed nulled leave with live enter in sort { }
 # - fixed reference constants (\"str")
 # - handle empty programs gracefully
 }
 
 # Changes between 0.50 and 0.51:
 # - fixed nulled leave with live enter in sort { }
 # - fixed reference constants (\"str")
 # - handle empty programs gracefully
-# - handle infinte loops (for (;;) {}, while (1) {})
+# - handle infinite loops (for (;;) {}, while (1) {})
 # - differentiate between `for my $x ...' and `my $x; for $x ...'
 # - various minor cleanups
 # - moved globals into an object
 # - differentiate between `for my $x ...' and `my $x; for $x ...'
 # - various minor cleanups
 # - moved globals into an object
@@ -98,10 +106,10 @@ BEGIN {
 # - added support for Ilya's OPpTARGET_MY optimization
 # - elided arrows before `()' subscripts when possible
 # Changes between 0.59 and 0.60
 # - added support for Ilya's OPpTARGET_MY optimization
 # - elided arrows before `()' subscripts when possible
 # Changes between 0.59 and 0.60
-# - support for method attribues was added
+# - support for method attributes was added
 # - some warnings fixed
 # - separate recognition of constant subs
 # - some warnings fixed
 # - separate recognition of constant subs
-# - rewrote continue block handling, now recoginizing for loops
+# - rewrote continue block handling, now recognizing for loops
 # - added more control of expanding control structures
 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
 # - many bug-fixes
 # - added more control of expanding control structures
 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
 # - many bug-fixes
@@ -159,7 +167,7 @@ BEGIN {
 #    'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
 # op/getpid 2 - can't assign to shared my() declaration (threads only)
 #    'my $x : shared = 5'
 #    'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
 # op/getpid 2 - can't assign to shared my() declaration (threads only)
 #    'my $x : shared = 5'
-# op/override 7 - parens on overriden require change v-string interpretation
+# op/override 7 - parens on overridden require change v-string interpretation
 #    'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
 #    c.f. 'BEGIN { *f = sub {0} }; f 2'
 # op/pat 774 - losing Unicode-ness of Latin1-only strings
 #    'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
 #    c.f. 'BEGIN { *f = sub {0} }; f 2'
 # op/pat 774 - losing Unicode-ness of Latin1-only strings
@@ -958,14 +966,19 @@ sub is_for_loop {
     my $op = shift;
     # This OP might be almost anything, though it won't be a
     # nextstate. (It's the initialization, so in the canonical case it
     my $op = shift;
     # This OP might be almost anything, though it won't be a
     # nextstate. (It's the initialization, so in the canonical case it
-    # will be an sassign.) The sibling is a lineseq whose first child
-    # is a nextstate and whose second is a leaveloop.
+    # will be an sassign.) The sibling is (old style) a lineseq whose
+    # first child is a nextstate and whose second is a leaveloop, or
+    # (new style) an unstack whose sibling is a leaveloop.
     my $lseq = $op->sibling;
     my $lseq = $op->sibling;
-    if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+    return 0 unless !is_state($op) and !null($lseq);
+    if ($lseq->name eq "lineseq") {
        if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
            && (my $sib = $lseq->first->sibling)) {
            return (!null($sib) && $sib->name eq "leaveloop");
        }
        if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
            && (my $sib = $lseq->first->sibling)) {
            return (!null($sib) && $sib->name eq "leaveloop");
        }
+    } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
+       my $sib = $lseq->sibling;
+       return $sib && !null($sib) && $sib->name eq "leaveloop";
     }
     return 0;
 }
     }
     return 0;
 }
@@ -1041,9 +1054,11 @@ sub maybe_local {
        and not $self->{'avoid_local'}{$$op}) {
        my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
        if( $our_local eq 'our' ) {
        and not $self->{'avoid_local'}{$$op}) {
        my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
        if( $our_local eq 'our' ) {
-           # XXX This assertion fails code with non-ASCII identifiers,
-           # like ./ext/Encode/t/jperl.t
-           die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+           if ( $text !~ /^\W(\w+::)*\w+\z/
+            and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
+           ) {
+               die "Unexpected our($text)\n";
+           }
            $text =~ s/(\w+::)+//;
        }
         if (want_scalar($op)) {
            $text =~ s/(\w+::)+//;
        }
         if (want_scalar($op)) {
@@ -1213,7 +1228,8 @@ sub walk_lineseq {
            }
        }
        if (is_for_loop($kids[$i])) {
            }
        }
        if (is_for_loop($kids[$i])) {
-           $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+           $callback->($expr . $self->for_loop($kids[$i], 0),
+               $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
            next;
        }
        $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
            next;
        }
        $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
@@ -1412,9 +1428,10 @@ sub pp_nextstate {
        $self->{'warnings'} = $warning_bits;
     }
 
        $self->{'warnings'} = $warning_bits;
     }
 
-    if ($self->{'hints'} != $op->hints) {
-       push @text, declare_hints($self->{'hints'}, $op->hints);
-       $self->{'hints'} = $op->hints;
+    my $hints = $] < 5.008009 ? $op->private : $op->hints;
+    if ($self->{'hints'} != $hints) {
+       push @text, declare_hints($self->{'hints'}, $hints);
+       $self->{'hints'} = $hints;
     }
 
     # hack to check that the hint hash hasn't changed
     }
 
     # hack to check that the hint hash hasn't changed
@@ -1642,6 +1659,7 @@ sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
 sub pp_each { unop(@_, "each") }
 sub pp_values { unop(@_, "values") }
 sub pp_keys { unop(@_, "keys") }
 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(@_,"");
 sub pp_boolkeys { 
     # no name because its an optimisation op that has no keyword
     unop(@_,"");
@@ -2387,6 +2405,9 @@ sub pp_syscall { listop(@_, "syscall") }
 sub pp_glob {
     my $self = shift;
     my($op, $cx) = @_;
 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 =~ /[<>]/) {
     my $text = $self->dq($op->first->sibling);  # skip pushmark
     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
        or $text =~ /[<>]/) {
@@ -2675,7 +2696,8 @@ sub loop_common {
            $ary = $self->deparse($ary, 1);
        }
        if (null $var) {
            $ary = $self->deparse($ary, 1);
        }
        if (null $var) {
-           if ($enter->flags & OPf_SPECIAL) { # thread special var
+           if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
+               # thread special var, under 5005threads
                $var = $self->pp_threadsv($enter, 1);
            } else { # regular my() variable
                $var = $self->pp_padsv($enter, 1);
                $var = $self->pp_threadsv($enter, 1);
            } else { # regular my() variable
                $var = $self->pp_padsv($enter, 1);
@@ -2755,7 +2777,9 @@ sub for_loop {
     my $self = shift;
     my($op, $cx) = @_;
     my $init = $self->deparse($op, 1);
     my $self = shift;
     my($op, $cx) = @_;
     my $init = $self->deparse($op, 1);
-    return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+    my $s = $op->sibling;
+    my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
+    return $self->loop_common($ll, $cx, $init);
 }
 
 sub pp_leavetry {
 }
 
 sub pp_leavetry {
@@ -2832,15 +2856,7 @@ sub pp_padsv {
 sub pp_padav { pp_padsv(@_) }
 sub pp_padhv { pp_padsv(@_) }
 
 sub pp_padav { pp_padsv(@_) }
 sub pp_padhv { pp_padsv(@_) }
 
-my @threadsv_names;
-
-BEGIN {
-    @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
-                      "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
-                      "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
-                      "!", "@");
-}
-
+my @threadsv_names = B::threadsv_names;
 sub pp_threadsv {
     my $self = shift;
     my($op, $cx) = @_;
 sub pp_threadsv {
     my $self = shift;
     my($op, $cx) = @_;
@@ -3381,15 +3397,7 @@ sub pp_entersub {
            return $prefix . $amper. $kid;
        }
     } else {
            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:://;
        # so it must have been translated from a keyword call. Translate
        # it back.
        $kid =~ s/^CORE::GLOBAL:://;
@@ -4075,19 +4083,26 @@ sub pp_trans {
     my $self = shift;
     my($op, $cx) = @_;
     my($from, $to);
     my $self = shift;
     my($op, $cx) = @_;
     my($from, $to);
-    if (class($op) eq "PVOP") {
-       ($from, $to) = tr_decode_byte($op->pv, $op->private);
+    my $class = class($op);
+    my $priv_flags = $op->private;
+    if ($class eq "PVOP") {
+       ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
+    } elsif ($class eq "PADOP") {
+       ($from, $to)
+         = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
     } else { # class($op) eq "SVOP"
     } else { # class($op) eq "SVOP"
-       ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+       ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
     }
     my $flags = "";
     }
     my $flags = "";
-    $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
-    $flags .= "d" if $op->private & OPpTRANS_DELETE;
+    $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
+    $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
     $to = "" if $from eq $to and $flags eq "";
     $to = "" if $from eq $to and $flags eq "";
-    $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+    $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
     return "tr" . double_delim($from, $to) . $flags;
 }
 
     return "tr" . double_delim($from, $to) . $flags;
 }
 
+sub pp_transr { &pp_trans . 'r' }
+
 sub re_dq_disambiguate {
     my ($first, $last) = @_;
     # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
 sub re_dq_disambiguate {
     my ($first, $last) = @_;
     # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
@@ -4221,6 +4236,7 @@ sub matchop {
     }
     my $quote = 1;
     my $extended = ($op->pmflags & PMf_EXTENDED);
     }
     my $quote = 1;
     my $extended = ($op->pmflags & PMf_EXTENDED);
+    my $rhs_bound_to_defsv;
     if (null $kid) {
        my $unbacked = re_unback($op->precomp);
        if ($extended) {
     if (null $kid) {
        my $unbacked = re_unback($op->precomp);
        if ($extended) {
@@ -4232,6 +4248,7 @@ sub matchop {
        carp("found ".$kid->name." where regcomp expected");
     } else {
        ($re, $quote) = $self->regcomp($kid, 21, $extended);
        carp("found ".$kid->name." where regcomp expected");
     } else {
        ($re, $quote) = $self->regcomp($kid, 21, $extended);
+       $rhs_bound_to_defsv = 1 if $kid->first->first->flags & OPf_SPECIAL;
     }
     my $flags = "";
     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
     }
     my $flags = "";
     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
@@ -4250,7 +4267,13 @@ sub matchop {
     }
     $re = $re . $flags if $quote;
     if ($binop) {
     }
     $re = $re . $flags if $quote;
     if ($binop) {
-       return $self->maybe_parens("$var =~ $re", $cx, 20);
+       return
+        $self->maybe_parens(
+         $rhs_bound_to_defsv
+          ? "$var =~ (\$_ =~ $re)"
+          : "$var =~ $re",
+         $cx, 20
+        );
     } else {
        return $re;
     }
     } else {
        return $re;
     }
@@ -4858,7 +4881,7 @@ which is not, consequently, deparsed correctly.
 
 Lexical (my) variables declared in scopes external to a subroutine
 appear in code2ref output text as package variables. This is a tricky
 
 Lexical (my) variables declared in scopes external to a subroutine
 appear in code2ref output text as package variables. This is a tricky
-problem, as perl has no native facility for refering to a lexical variable
+problem, as perl has no native facility for referring to a lexical variable
 defined within a different scope, although L<PadWalker> is a good start.
 
 =item *
 defined within a different scope, although L<PadWalker> is a good start.
 
 =item *
Unnamed repository; edit this file 'description' to name the repository.