Make constant promotion null-clean

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

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 4df3245..cb54b95 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -25,8 +25,10 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         ($] < 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.08";
+        ($] < 5.013 ? () : 'PMf_NONDESTRUCT'),
+        ($] < 5.015003 ? qw(OPpCONST_ARYBASE) : ()),
+        ($] < 5.015005 ? () : qw(OPpEVAL_BYTES));
+$VERSION = "1.09";
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -36,7 +38,7 @@ BEGIN {
     # 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)) {
+               PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
        no strict 'refs';
        *{$_} = sub () {0} unless *{$_}{CODE};
     }
@@ -579,6 +581,7 @@ sub new {
     $self->{'use_dumper'} = 0;
     $self->{'use_tabs'} = 0;
 
+    $self->{'ambient_arybase'} = 0;
     $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
     $self->{'ambient_hints'} = 0;
     $self->{'ambient_hinthash'} = undef;
@@ -624,6 +627,7 @@ sub new {
 sub init {
     my $self = shift;
 
+    $self->{'arybase'}  = $self->{'ambient_arybase'};
     $self->{'warnings'} = defined ($self->{'ambient_warnings'})
                                ? $self->{'ambient_warnings'} & WARN_MASK
                                : undef;
@@ -707,7 +711,7 @@ sub coderef2text {
 
 sub ambient_pragmas {
     my $self = shift;
-    my ($hint_bits, $warning_bits, $hinthash) = (0);
+    my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
 
     while (@_ > 1) {
        my $name = shift();
@@ -734,6 +738,14 @@ sub ambient_pragmas {
            $hint_bits |= strict::bits(@names);
        }
 
+       elsif ($name eq '$[') {
+           if (OPpCONST_ARYBASE) {
+               $arybase = $val;
+           } else {
+               croak "\$[ can't be non-zero on this perl" unless $val == 0;
+           }
+       }
+
        elsif ($name eq 'integer'
            || $name eq 'bytes'
            || $name eq 'utf8') {
@@ -804,6 +816,7 @@ sub ambient_pragmas {
        croak "The ambient_pragmas method expects an even number of args";
     }
 
+    $self->{'ambient_arybase'} = $arybase;
     $self->{'ambient_warnings'} = $warning_bits;
     $self->{'ambient_hints'} = $hint_bits;
     $self->{'ambient_hinthash'} = $hinthash;
@@ -1278,10 +1291,16 @@ sub stash_variable {
        return "$prefix$name";
     }
 
-    if (defined $cx && $cx == 26) {
-       if ($prefix eq '@' && $name =~ /^[^\w+-]$/) {
+    if ($name =~ /^[^\w+-]$/) {
+      if (defined $cx && $cx == 26) {
+       if ($prefix eq '@') {
            return "$prefix\{$name}";
        }
+       elsif ($name eq '#') { return '${#}' } #  "${#}a" vs "$#a"
+      }
+      if ($prefix eq '$#') {
+       return "\$#{$name}";
+      }
     }
 
     my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
@@ -1392,7 +1411,7 @@ sub seq_subs {
 }
 
 # Notice how subs and formats are inserted between statements here;
-# also pragmas.
+# also $[ assignments and pragmas.
 sub pp_nextstate {
     my $self = shift;
     my($op, $cx) = @_;
@@ -1405,6 +1424,11 @@ sub pp_nextstate {
        $self->{'curstash'} = $stash;
     }
 
+    if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
+       push @text, '$[ = '. $op->arybase .";\n";
+       $self->{'arybase'} = $op->arybase;
+    }
+
     my $warnings = $op->warnings;
     my $warning_bits;
     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
@@ -1527,6 +1551,7 @@ my %feature_keywords = (
     when    => 'switch',
     default => 'switch',
     break   => 'switch',
+    evalbytes=>'evalbytes',
 );
 
 sub keyword {
@@ -1534,14 +1559,12 @@ sub keyword {
     my $name = shift;
     return $name if $name =~ /^CORE::/; # just in case
     if (exists $feature_keywords{$name}) {
-       return
-         $self->{'hinthash'}
-          && $self->{'hinthash'}{"feature_$feature_keywords{$name}"}
-           ? $name
-           : "CORE::$name";
+       return "CORE::$name"
+        if !$self->{'hinthash'}
+        || !$self->{'hinthash'}{"feature_$feature_keywords{$name}"}
     }
     if (
-      $name !~ /^(?:chom?p|exec|s(?:elect|ystem))\z/
+      $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
        && !defined eval{prototype "CORE::$name"}
     ) { return $name }
     if (
@@ -1736,7 +1759,12 @@ sub pp_alarm { unop(@_, "alarm") }
 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
 
 sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
+sub pp_entereval {
+    unop(
+      @_,
+      $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+    )
+}
 
 sub pp_ghbyname { unop(@_, "gethostbyname") }
 sub pp_gnbyname { unop(@_, "getnetbyname") }
@@ -2438,9 +2466,12 @@ sub pp_glob {
     my $self = shift;
     my($op, $cx) = @_;
     my $text = $self->dq($op->first->sibling);  # skip pushmark
+    my $keyword =
+       $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
-       or $text =~ /[<>]/) {
-       return 'glob(' . single_delim('qq', '"', $text) . ')';
+       or $keyword =~ /^CORE::/
+        or $text =~ /[<>]/) {
+       return "$keyword(" . single_delim('qq', '"', $text) . ')';
     } else {
        return '<' . $text . '>';
     }
@@ -2567,6 +2598,7 @@ sub pp_list {
     my($op, $cx) = @_;
     my($expr, @exprs);
     my $kid = $op->first->sibling; # skip pushmark
+    return '' if class($kid) eq 'NULL';
     my $lop;
     my $local = "either"; # could be local(...), my(...), state(...) or our(...)
     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
@@ -2931,7 +2963,7 @@ sub pp_aelemfast_lex {
     my($op, $cx) = @_;
     my $name = $self->padname($op->targ);
     $name =~ s/^@/\$/;
-    return $name . "[" . $op->private . "]";
+    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
 }
 
 sub pp_aelemfast {
@@ -2945,7 +2977,7 @@ sub pp_aelemfast {
     $name = $self->{'curstash'}."::$name"
        if $name !~ /::/ && $self->lex_in_scope('@'.$name);
     $name = '$' . $name;
-    return $name . "[" . $op->private . "]";
+    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
 }
 
 sub rv2x {
@@ -3824,6 +3856,9 @@ sub const_sv {
 sub pp_const {
     my $self = shift;
     my($op, $cx) = @_;
+    if ($op->private & OPpCONST_ARYBASE) {
+        return '$[';
+    }
 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
 #      return $self->const_sv($op)->PV;
 #    }
@@ -3836,6 +3871,7 @@ sub dq {
     my $op = shift;
     my $type = $op->name;
     if ($type eq "const") {
+       return '$[' if $op->private & OPpCONST_ARYBASE;
        return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
     } elsif ($type eq "concat") {
        my $first = $self->dq($op->first);
@@ -4160,6 +4196,7 @@ sub re_dq {
 
     my $type = $op->name;
     if ($type eq "const") {
+       return '$[' if $op->private & OPpCONST_ARYBASE;
        my $unbacked = re_unback($self->const_sv($op)->as_string);
        return re_uninterp_extended(escape_extended_re($unbacked))
            if $extended;
@@ -4703,7 +4740,7 @@ after B<-MO=Deparse> should be given as separate strings.
 
 =head2 ambient_pragmas
 
-    $deparse->ambient_pragmas(strict => 'all');
+    $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
 
 The compilation of a subroutine can be affected by a few compiler
 directives, B<pragmas>. These are:
@@ -4720,6 +4757,10 @@ use warnings;
 
 =item *
 
+Assigning to the special variable $[
+
+=item *
+
 use integer;
 
 =item *
@@ -4762,6 +4803,11 @@ expect.
 
     $deparse->ambient_pragmas(strict => 'subs refs');
 
+=item $[
+
+Takes a number, the value of the array base $[.
+Cannot be non-zero on Perl 5.15.3 or later.
+
 =item bytes
 
 =item utf8
@@ -4815,6 +4861,7 @@ They exist principally so that you can write code like:
     $deparser->ambient_pragmas (
        hint_bits    => $hint_bits,
        warning_bits => $warning_bits,
+       '$['         => 0 + $[
     ); }
 
 which specifies that the ambient pragmas are exactly those which
@@ -4847,7 +4894,8 @@ the main:: package, the code will include a package declaration.
 =item *
 
 The only pragmas to be completely supported are: C<use warnings>,
-C<use strict 'refs'>, C<use bytes>, and C<use integer>.
+C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
+behaves like a pragma, is also supported.)
 
 Excepting those listed above, we're currently unable to guarantee that
 B::Deparse will produce a pragma at the correct point in the program.