This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse our(LIST) correctly
[perl5.git] / lib / B / Deparse.pm
index 3800171..a9ddabd 100644 (file)
@@ -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.24';
+$VERSION = '1.27';
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -316,6 +316,9 @@ BEGIN {
 
 
 
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) {
+    eval "sub OP_\U$_ () { " . opnumber($_) . "}"
+}}
 
 # _pessimise_walk(): recursively walk the optree of a sub,
 # possibly undoing optimisations along the way.
@@ -345,6 +348,7 @@ sub _pessimise_walk {
            # the original gv[_].
 
            $B::overlay->{$$op} = {
+                   type => OP_PUSHMARK,
                    name => 'pushmark',
                    private => ($op->private & OPpLVAL_INTRO),
                    next    => ($op->flags & OPf_SPECIAL)
@@ -1191,8 +1195,7 @@ sub maybe_local {
     my $self = shift;
     my($op, $cx, $text) = @_;
     my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
-    if ($op->private & (OPpLVAL_INTRO|$our_intro)
-       and not $self->{'avoid_local'}{$$op}) {
+    if ($op->private & (OPpLVAL_INTRO|$our_intro)) {
        my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
        if( $our_local eq 'our' ) {
            if ( $text !~ /^\W(\w+::)*\w+\z/
@@ -1202,6 +1205,7 @@ sub maybe_local {
            }
            $text =~ s/(\w+::)+//;
        }
+       return $text if $self->{'avoid_local'}{$$op};
         if (want_scalar($op)) {
            return "$our_local $text";
        } else {
@@ -2664,7 +2668,6 @@ sub listop {
                : $self->keyword($name) . '()' x (7 < $cx);
     }
     my $first;
-    $name = "socketpair" if $name eq "sockpair";
     my $fullname = $self->keyword($name);
     my $proto = prototype("CORE::$name");
     if (
@@ -2763,7 +2766,7 @@ sub pp_fcntl { listop(@_, "fcntl") }
 sub pp_ioctl { listop(@_, "ioctl") }
 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
 sub pp_socket { listop(@_, "socket") }
-sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_sockpair { listop(@_, "socketpair") }
 sub pp_bind { listop(@_, "bind") }
 sub pp_connect { listop(@_, "connect") }
 sub pp_listen { listop(@_, "listen") }
@@ -3209,9 +3212,12 @@ sub pp_leavetry {
     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
 }
 
-BEGIN { for (qw[ const stringify rv2sv list glob ]) {
-    eval "sub OP_\U$_ () { " . opnumber($_) . "}"
-}}
+sub _op_is_or_was {
+  my ($op, $expect_type) = @_;
+  my $type = $op->type;
+  return($type == $expect_type
+         || ($type == OP_NULL && $op->targ == $expect_type));
+}
 
 sub pp_null {
     my $self = shift;
@@ -3219,7 +3225,10 @@ sub pp_null {
     if (class($op) eq "OP") {
        # old value is lost
        return $self->{'ex_const'} if $op->targ == OP_CONST;
-    } elsif ($op->first->name eq "pushmark") {
+    } elsif ($op->first->name eq 'pushmark'
+             or $op->first->name eq 'null'
+                && $op->first->targ == OP_PUSHMARK
+                && _op_is_or_was($op, OP_LIST)) {
        return $self->pp_list($op, $cx);
     } elsif ($op->first->name eq "enter") {
        return $self->pp_leave($op, $cx);
@@ -3323,7 +3332,9 @@ sub pp_aelemfast_lex {
     my($op, $cx) = @_;
     my $name = $self->padname($op->targ);
     $name =~ s/^@/\$/;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub pp_aelemfast {
@@ -3335,7 +3346,9 @@ sub pp_aelemfast {
     my $gv = $self->gv_or_padgv($op);
     my($name,$quoted) = $self->stash_variable_name('@',$gv);
     $name = $quoted ? "$name->" : '$' . $name;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub rv2x {
@@ -3389,7 +3402,7 @@ sub pp_av2arylen {
 sub pp_rv2cv {
     my ($self, $op, $cx) = @_;
     if (!null($op->first) && $op->first->name eq 'null' &&
-       $op->first->targ eq OP_LIST)
+       $op->first->targ == OP_LIST)
     {
        return $self->rv2x($op->first->first->sibling, $cx, "&")
     }
@@ -3699,8 +3712,9 @@ sub check_proto {
     my @reals;
     # An unbackslashed @ or % gobbles up the rest of the args
     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+    $proto =~ s/^\s*//;
     while ($proto) {
-       $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
+       $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
        my $chr = $1;
        if ($chr eq "") {
            return "&" if @args;
@@ -3857,7 +3871,7 @@ sub pp_entersub {
        my $dproto = defined($proto) ? $proto : "undefined";
         if (!$declared) {
            return "$kid(" . $args . ")";
-       } elsif ($dproto eq "") {
+       } elsif ($dproto =~ /^\s*\z/) {
            return $kid;
        } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
            # is_scalar is an excessively conservative test here:
@@ -4634,7 +4648,7 @@ sub pure_string {
     }
     elsif ($type eq 'join') {
        my $join_op = $op->first->sibling;  # Skip pushmark
-       return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+       return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
 
        my $gvop = $join_op->first;
        return 0 unless $gvop->name eq 'gvsv';
@@ -4775,7 +4789,7 @@ sub matchop {
     $flags = $matchwords{$flags} if $matchwords{$flags};
     if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
        $re =~ s/\?/\\?/g;
-       $re = "?$re?";
+       $re = "m?$re?";        # explicit 'm' is required
     } elsif ($quote) {
        $re = single_delim($name, $delim, $re);
     }
@@ -5322,7 +5336,7 @@ parameter twice:
        warnings => [FATAL => qw/void io/],
     );
 
-See L<perllexwarn> for more information about lexical warnings.
+See L<warnings> for more information about lexical warnings.
 
 =item hint_bits