This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] t/TEST -deparse fixups
authorDavid Mitchell <davem@iabyn.com>
Thu, 23 Nov 2017 10:45:59 +0000 (10:45 +0000)
committerDavid Mitchell <davem@iabyn.com>
Thu, 23 Nov 2017 10:45:59 +0000 (10:45 +0000)
One of my occasional attempts to fix regressions in 'TEST -deparse' -
which runs every test script through the deparser, then tries to execute
it.

This branch fixes the following regressing scripts:

    opbasic/concat.t
    op/hash.t
    op/sort.t
    op/state.t
    ../cpan/Test-Harness/t/compat/test-harness-compat.t
    ../dist/autouse/t/autouse.t
    ../ext/XS-Typemap/t/Typemap.t

and updates Porting/deparse-skips.txt to note the following
expected-to-fail scripts are now passing:

    ../cpan/Socket/t/sockaddr.t
    ../dist/IO/t/io_sel.t
    ../dist/PathTools/t/cwd.t
    ../dist/Storable/t/blessed.t
    ../ext/B/t/xref.t
    ../lib/Benchmark.t

and marks the following as a new expected-fail (due to hard-coded line
numbers in tests):

    ../cpan/Test-Simple/t/Legacy/no_plan.t

Porting/deparse-skips.txt
dist/autouse/t/autouse.t
lib/B/Deparse-core.t
lib/B/Deparse.pm
lib/B/Deparse.t
lib/B/Op_private.pm
op.c
opcode.h
regen/op_private
t/TEST

index 130fcaa..29f0e96 100644 (file)
@@ -160,11 +160,11 @@ uni/variables.t
 ../cpan/Module-Metadata/t/metadata.t
 ../cpan/Scalar-List-Utils/t/subname.t
 ../cpan/Scalar-List-Utils/t/uniq.t
-../cpan/Socket/t/sockaddr.t
 ../cpan/Term-Cap/test.pl
 ../cpan/Test-Simple/t/Legacy/Builder/carp.t
 ../cpan/Test-Simple/t/Legacy/fail-more.t
 ../cpan/Test-Simple/t/Legacy/is_deeply_fail.t
+../cpan/Test-Simple/t/Legacy/no_plan.t         # hard-coded line numbers
 ../cpan/Test-Simple/t/Legacy/plan_bad.t
 ../cpan/Test-Simple/t/Legacy/plan.t
 ../cpan/Test-Simple/t/Legacy/subtest/line_numbers.t
@@ -181,15 +181,11 @@ uni/variables.t
 ../dist/Data-Dumper/t/trailing_comma.t
 ../dist/Exporter/t/Exporter.t
 ../dist/Filter-Simple/t/data.t
-../dist/IO/t/io_sel.t
-../dist/PathTools/t/cwd.t
-../dist/Storable/t/blessed.t
 ../dist/Storable/t/croak.t
 ../dist/threads/t/blocks.t
 ../ext/B/t/b.t
 ../ext/B/t/optree_constants.t
 ../ext/B/t/optree_samples.t
-../ext/B/t/xref.t
 ../ext/Devel-Peek/t/Peek.t
 ../ext/IPC-Open3/t/IPC-Open2.t
 ../ext/IPC-Open3/t/IPC-Open3.t
@@ -200,7 +196,6 @@ uni/variables.t
 ../ext/XS-APItest/t/fetch_pad_names.t
 ../ext/XS-APItest/t/svpeek.t
 ../ext/XS-APItest/t/synthetic_scope.t
-../lib/Benchmark.t
 ../lib/charnames.t
 ../lib/dumpvar.t
 ../lib/English.t
index a790403..20ad9eb 100644 (file)
@@ -98,13 +98,14 @@ SKIP: {
 SKIP: {
     skip "Fails in 5.15.5 and below (perl bug)", 1 if $] < 5.0150051;
     use Config;
-    skip "no B", 1 unless $Config{extensions} =~ /\bB\b/;
+    skip "no Hash::Util", 1 unless $Config{extensions} =~ /\bHash::Util\b/;
     use warnings; local $^W = 1; no warnings 'once';
     my $w;
     local $SIG{__WARN__} = sub { $w .= shift };
-    use autouse B => "sv_undef";
-    *B::sv_undef = \&sv_undef;
-    require B;
+    # any old XS sub from any old module which uses Exporter
+    use autouse 'Hash::Util' => "all_keys";
+    *Hash::Util::all_keys = \&all_keys;
+    require Hash::Util;
     is $w, undef,
       'no redefinition warning when clobbering autouse stub with new XSUB';
 }
index 2ed797a..6ee935f 100644 (file)
@@ -80,21 +80,23 @@ sub testit {
        $desc .= " (lex sub)" if $lexsub;
 
 
+        my $code;
        my $code_ref;
        if ($lexsub) {
            package lexsubtest;
            no warnings 'experimental::lexical_subs';
            use feature 'lexical_subs';
            no strict 'vars';
-           $code_ref =
-               eval "sub { state sub $keyword; ${vars}() = $expr }"
-                           || die "$@ in $expr";
+            $code = "sub { state sub $keyword; ${vars}() = $expr }";
+           $code_ref = eval $code
+                           or die "$@ in $expr";
        }
        else {
            package test;
            use subs ();
            import subs $keyword;
-           $code_ref = eval "no strict 'vars'; sub { ${vars}() = $expr }"
+           $code = "no strict 'vars'; sub { ${vars}() = $expr }";
+           $code_ref = eval $code
                            or die "$@ in $expr";
        }
 
@@ -115,7 +117,8 @@ sub testit {
        }
 
        my $got_expr = $1;
-       is $got_expr, $expected_expr, $desc;
+       is $got_expr, $expected_expr, $desc
+            or ::diag("ORIGINAL CODE:\n$code");;
     }
 }
 
@@ -639,7 +642,7 @@ sprintf          123   p
 sqrt             01    $
 srand            01    -
 stat             01    $
-state            123   p+ # skip with 0 args, as state() => ()
+state            123   p1+ # skip with 0 args, as state() => ()
 study            01    $+
 # sub handled specially
 substr           234   p
index 33b9b1e..552798d 100644 (file)
@@ -19,6 +19,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
          OPpSPLIT_ASSIGN OPpSPLIT_LEX
          OPpPADHV_ISKEYS OPpRV2HV_ISKEYS
+         OPpCONCAT_NESTED
          OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
          OPpTRUEBOOL OPpINDEX_BOOLNEG
         SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
@@ -51,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.45';
+$VERSION = '1.46';
 use strict;
 our $AUTOLOAD;
 use warnings ();
@@ -655,7 +656,8 @@ sub stash_subs {
        if ($seen ||= {})->{
            $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
           }++;
-    my %stash = svref_2object($stash)->ARRAY;
+    my $stashobj = svref_2object($stash);
+    my %stash = $stashobj->ARRAY;
     while (my ($key, $val) = each %stash) {
        my $flags = $val->FLAGS;
        if ($flags & SVf_ROK) {
@@ -696,7 +698,20 @@ sub stash_subs {
        } elsif (class($val) eq "GV") {
            if (class(my $cv = $val->CV) ne "SPECIAL") {
                next if $self->{'subs_done'}{$$val}++;
-               next if $$val != ${$cv->GV};   # Ignore imposters
+
+                # Ignore imposters (aliases etc)
+                my $name = $cv->NAME_HEK;
+                if(defined $name) {
+                    # avoid using $cv->GV here because if the $val GV is
+                    # an alias, CvGV() could upgrade the real stash entry
+                    # from an RV to a GV
+                    next unless $name eq $key;
+                    next unless $$stashobj == ${$cv->STASH};
+                }
+                else {
+                   next if $$val != ${$cv->GV};
+                }
+
                $self->todo($cv, 0);
            }
            if (class(my $cv = $val->FORM) ne "SPECIAL") {
@@ -2130,12 +2145,18 @@ sub pp_nextstate {
 
 sub declare_warnings {
     my ($self, $from, $to) = @_;
-    if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
-       return $self->keyword("use") . " warnings;\n";
-    }
-    elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
-       return $self->keyword("no") . " warnings;\n";
+    $from //= '';
+    my $all = (warnings::bits("all") & WARN_MASK);
+    unless ((($from & WARN_MASK) & ~$all) =~ /[^\0]/) {
+        # no FATAL bits need turning off
+        if (   ($to & WARN_MASK) eq $all) {
+            return $self->keyword("use") . " warnings;\n";
+        }
+        elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
+            return $self->keyword("no") . " warnings;\n";
+        }
     }
+
     return "BEGIN {\${^WARNING_BITS} = \""
            . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
            . "\"}\n\cK";
@@ -2950,7 +2971,7 @@ sub binop {
     my $leftop = $left;
     $left = $self->deparse_binop_left($op, $left, $prec);
     $left = "($left)" if $flags & LIST_CONTEXT
-                    and    $left !~ /^(my|our|local|)[\@\(]/
+                    and    $left !~ /^(my|our|local|state|)\s*[\@%\(]/
                         || do {
                                # Parenthesize if the left argument is a
                                # lone repeat op.
@@ -3033,7 +3054,8 @@ sub real_concat {
     my $right = $op->last;
     my $eq = "";
     my $prec = 18;
-    if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
+    if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) {
+        # '.=' rather than optimised '.'
        $eq = "=";
        $prec = 7;
     }
@@ -3486,8 +3508,8 @@ BEGIN {
 }
 
 
-# Look for a my attribute declaration in a list or ex-list. Returns undef
-# if not found, 'my($x, @a) :Foo(bar)' etc otherwise.
+# Look for a my/state attribute declaration in a list or ex-list.
+# Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise.
 #
 # There are three basic tree structs that are expected:
 #
@@ -3532,7 +3554,7 @@ BEGIN {
 #           <$> const[PV "foo"] sM ->a
 #           <.> method_named[PV "import"] ->b
 
-sub maybe_my_attr {
+sub maybe_var_attr {
     my ($self, $op, $cx) = @_;
 
     my $kid = $op->first->sibling; # skip pushmark
@@ -3545,13 +3567,13 @@ sub maybe_my_attr {
     # @padops and @entersubops. Return if anything else seen.
     # Also determine what class (if any) all the pad vars belong to
     my $class;
+    my $decl; # 'my' or 'state'
     my (@padops, @entersubops);
     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
        my $lopname = $lop->name;
        my $loppriv = $lop->private;
         if ($lopname =~ /^pad[sah]v$/) {
             return unless $loppriv & OPpLVAL_INTRO;
-            return if     $loppriv & OPpPAD_STATE;
 
             my $padname = $self->padname_sv($lop->targ);
             my $thisclass = ($padname->FLAGS & SVpad_TYPED)
@@ -3561,6 +3583,14 @@ sub maybe_my_attr {
             $class //= $thisclass;
             return unless $thisclass eq $class;
 
+            # all pad vars must be the same sort of declaration
+            # (all my, all state, etc)
+            my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my';
+            if (defined $decl) {
+                return unless $this eq $decl;
+            }
+            $decl = $this;
+
             push @padops, $lop;
         }
         elsif ($lopname eq 'entersub') {
@@ -3625,7 +3655,7 @@ sub maybe_my_attr {
         return if $$kid;
     }
 
-    my $res = 'my';
+    my $res = $decl;
     $res .= " $class " if $class ne 'main';
     $res .=
             (@varnames > 1)
@@ -3642,7 +3672,7 @@ sub pp_list {
 
     {
         # might be my ($s,@a,%h) :Foo(bar);
-        my $my_attr = maybe_my_attr($self, $op, $cx);
+        my $my_attr = maybe_var_attr($self, $op, $cx);
         return $my_attr if defined $my_attr;
     }
 
@@ -3723,6 +3753,10 @@ sub pp_list {
        push @exprs, $expr;
     }
     if ($local) {
+        if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) {
+            # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't
+            return "$local $exprs[0]";
+        }
        return "$local(" . join(", ", @exprs) . ")";
     } else {
        return $self->maybe_parens( join(", ", @exprs), $cx, 6);        
@@ -3942,7 +3976,7 @@ sub pp_null {
 
     # might be 'my $s :Foo(bar);'
     if ($op->targ == OP_LIST) {
-        my $my_attr = maybe_my_attr($self, $op, $cx);
+        my $my_attr = maybe_var_attr($self, $op, $cx);
         return $my_attr if defined $my_attr;
     }
 
@@ -4023,15 +4057,29 @@ sub pp_padsv {
 
 sub pp_padav { pp_padsv(@_) }
 
+# prepend 'keys' where its been optimised away, with suitable handling
+# of CORE:: and parens
+
+sub add_keys_keyword {
+    my ($self, $str, $cx) = @_;
+    $str = $self->maybe_parens($str, $cx, 16);
+    # 'keys %h' versus 'keys(%h)'
+    $str = " $str" unless $str =~ /^\(/;
+    return $self->keyword("keys") . $str;
+}
+
 sub pp_padhv {
-    my $op = $_[1];
-    my $keys = '';
+    my ($self, $op, $cx) = @_;
+    my $str =  pp_padsv(@_);
     # with OPpPADHV_ISKEYS the keys op is optimised away, except
     # in scalar context the old op is kept (but not executed) so its targ
     # can be used.
-    $keys = 'keys ' if (     ($op->private & OPpPADHV_ISKEYS)
-                            && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR));
-    $keys . pp_padsv(@_);
+    if (     ($op->private & OPpPADHV_ISKEYS)
+        && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR))
+    {
+        $str = $self->add_keys_keyword($str, $cx);
+    }
+    $str;
 }
 
 sub gv_or_padgv {
@@ -4119,9 +4167,12 @@ sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
 
 sub pp_rv2hv {
-    my $op = $_[1];
-    (($op->private & OPpRV2HV_ISKEYS) ? 'keys ' : '')
-        . maybe_local(@_, rv2x(@_, "%"))
+    my ($self, $op, $cx) = @_;
+    my $str = rv2x(@_, "%");
+    if ($op->private & OPpRV2HV_ISKEYS) {
+        $str = $self->add_keys_keyword($str, $cx);
+    }
+    return maybe_local(@_, $str);
 }
 
 # skip rv2av
@@ -4372,8 +4423,12 @@ sub do_multiconcat {
         # "foo=$foo bar=$bar "
         my $not_first;
         while (@consts) {
-            $rhs = dq_disambiguate($rhs, $self->dq(shift(@kids), 18))
-                if $not_first;
+            if ($not_first) {
+                my $s = $self->dq(shift(@kids), 18);
+                # don't deparse "a${$}b" as "a$$b"
+                $s = '${$}' if $s eq '$$';
+                $rhs = dq_disambiguate($rhs, $s);
+            }
             $not_first = 1;
             my $c = shift @consts;
             if (defined $c) {
index f8da646..2094a37 100644 (file)
@@ -13,7 +13,7 @@ BEGIN {
 use warnings;
 use strict;
 
-my $tests = 49; # not counting those in the __DATA__ section
+my $tests = 52; # not counting those in the __DATA__ section
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -546,6 +546,22 @@ unlike runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-w' ],
        qr'Use of uninitialized value',
       'no warnings for undefined sub';
 
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+    prog => 'sub f { 1; } BEGIN { *g = \&f; }'),
+    "sub f {\n    1;\n}\nsub BEGIN {\n    *g = \\&f;\n}\n",
+    "sub glob alias shouldn't impede emitting original sub";
+
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+    prog => 'package Foo; sub f { 1; } BEGIN { *g = \&f; }'),
+    "package Foo;\nsub f {\n    1;\n}\nsub BEGIN {\n    *g = \\&f;\n}\n",
+    "sub glob alias outside main shouldn't impede emitting original sub";
+
+is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
+    prog => 'package Foo; sub f { 1; } BEGIN { *Bar::f = \&f; }'),
+    "package Foo;\nsub f {\n    1;\n}\nsub BEGIN {\n    *Bar::f = \\&f;\n}\n",
+    "sub glob alias in separate package shouldn't impede emitting original sub";
+
+
 done_testing($tests);
 
 __DATA__
@@ -2935,3 +2951,54 @@ use strict 'vars';
 print exists &main::foo;
 print exists &{foo};
 print exists &main::bar;
+# precedence of optimised-away 'keys' (OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS)
+my($r1, %h1, $res);
+our($r2, %h2);
+$res = keys %h1;
+$res = keys %h2;
+$res = keys %$r1;
+$res = keys %$r2;
+$res = keys(%h1) / 2 - 1;
+$res = keys(%h2) / 2 - 1;
+$res = keys(%$r1) / 2 - 1;
+$res = keys(%$r2) / 2 - 1;
+####
+# ditto in presence of sub keys {}
+# CONTEXT sub keys {}
+no warnings;
+my($r1, %h1, $res);
+our($r2, %h2);
+CORE::keys %h1;
+CORE::keys(%h1) / 2;
+$res = CORE::keys %h1;
+$res = CORE::keys %h2;
+$res = CORE::keys %$r1;
+$res = CORE::keys %$r2;
+$res = CORE::keys(%h1) / 2 - 1;
+$res = CORE::keys(%h2) / 2 - 1;
+$res = CORE::keys(%$r1) / 2 - 1;
+$res = CORE::keys(%$r2) / 2 - 1;
+####
+# concat: STACKED: ambiguity between .= and optimised nested
+my($a, $b);
+$b = $a . $a . $a;
+(($a .= $a) .= $a) .= $a;
+####
+# multiconcat: $$ within string
+my($a, $x);
+$x = "${$}abc";
+$x = "\$$a";
+####
+# single state aggregate assignment
+# CONTEXT use feature "state";
+state @a = (1, 2, 3);
+state %h = ('a', 1, 'b', 2);
+####
+# state var with attribute
+# CONTEXT use feature "state";
+state $x :shared;
+state $y :shared = 1;
+state @a :shared;
+state @b :shared = (1, 2);
+state %h :shared;
+state %i :shared = ('a', 1, 'b', 2);
index 37497af..af673aa 100644 (file)
@@ -285,7 +285,7 @@ $bits{chroot}{0} = $bf[0];
 @{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{closedir}{0} = $bf[0];
 $bits{complement}{0} = $bf[0];
-@{$bits{concat}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]);
 $bits{cond_expr}{0} = $bf[0];
 @{$bits{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
@@ -600,6 +600,7 @@ our %defines = (
     OPpASSIGN_CV_TO_GV       => 128,
     OPpASSIGN_TRUEBOOL       =>   4,
     OPpAVHVSWITCH_MASK       =>   3,
+    OPpCONCAT_NESTED         =>  64,
     OPpCONST_BARE            =>  64,
     OPpCONST_ENTERED         =>  16,
     OPpCONST_NOVER           =>   2,
@@ -706,6 +707,7 @@ our %labels = (
     OPpASSIGN_COMMON_SCALAR  => 'COM_SCALAR',
     OPpASSIGN_CV_TO_GV       => 'CV2GV',
     OPpASSIGN_TRUEBOOL       => 'BOOL',
+    OPpCONCAT_NESTED         => 'NESTED',
     OPpCONST_BARE            => 'BARE',
     OPpCONST_ENTERED         => 'ENTERED',
     OPpCONST_NOVER           => 'NOVER',
@@ -802,6 +804,7 @@ our %ops_using = (
     OPpALLOW_FAKE            => [qw(rv2gv)],
     OPpASSIGN_BACKWARDS      => [qw(sassign)],
     OPpASSIGN_COMMON_AGG     => [qw(aassign)],
+    OPpCONCAT_NESTED         => [qw(concat)],
     OPpCONST_BARE            => [qw(const)],
     OPpCOREARGS_DEREF1       => [qw(coreargs)],
     OPpEARLY_CV              => [qw(gv)],
diff --git a/op.c b/op.c
index 8a185a1..ec45f2c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10850,7 +10850,10 @@ Perl_ck_concat(pTHX_ OP *o)
     /* reuse the padtmp returned by the concat child */
     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
            !(kUNOP->op_first->op_flags & OPf_MOD))
+    {
         o->op_flags |= OPf_STACKED;
+        o->op_private |= OPpCONCAT_NESTED;
+    }
     return o;
 }
 
index b5ed37f..2556a01 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -2276,6 +2276,7 @@ END_EXTERN_C
 #define OPpALLOW_FAKE           0x40
 #define OPpASSIGN_BACKWARDS     0x40
 #define OPpASSIGN_COMMON_SCALAR 0x40
+#define OPpCONCAT_NESTED        0x40
 #define OPpCONST_BARE           0x40
 #define OPpCOREARGS_SCALARMOD   0x40
 #define OPpENTERSUB_DB          0x40
@@ -2392,6 +2393,7 @@ EXTCONST char PL_op_private_labels[] = {
     'L','V','S','U','B','\0',
     'M','A','R','K','\0',
     'N','E','G','\0',
+    'N','E','S','T','E','D','\0',
     'N','O','(',')','\0',
     'N','O','I','N','I','T','\0',
     'N','O','V','E','R','\0',
@@ -2440,14 +2442,14 @@ EXTCONST char PL_op_private_labels[] = {
 EXTCONST I16 PL_op_private_bitfields[] = {
     0, 8, -1,
     0, 8, -1,
-    0, 576, -1,
+    0, 583, -1,
     0, 8, -1,
     0, 8, -1,
-    0, 583, -1,
-    0, 572, -1,
-    1, -1, 0, 540, 1, 40, 2, 290, -1,
+    0, 590, -1,
+    0, 579, -1,
+    1, -1, 0, 547, 1, 40, 2, 290, -1,
     4, -1, 1, 171, 2, 178, 3, 185, -1,
-    4, -1, 0, 540, 1, 40, 2, 290, 3, 117, -1,
+    4, -1, 0, 547, 1, 40, 2, 290, 3, 117, -1,
 
 };
 
@@ -2522,9 +2524,9 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       80, /* i_add */
       80, /* subtract */
       80, /* i_subtract */
-      80, /* concat */
-      84, /* multiconcat */
-      90, /* stringify */
+      84, /* concat */
+      87, /* multiconcat */
+      93, /* stringify */
       80, /* left_shift */
       80, /* right_shift */
       12, /* lt */
@@ -2564,11 +2566,11 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       75, /* ncomplement */
       75, /* scomplement */
       12, /* smartmatch */
-      90, /* atan2 */
+      93, /* atan2 */
       75, /* sin */
       75, /* cos */
-      90, /* rand */
-      90, /* srand */
+      93, /* rand */
+      93, /* srand */
       75, /* exp */
       75, /* log */
       75, /* sqrt */
@@ -2576,97 +2578,97 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       75, /* hex */
       75, /* oct */
       75, /* abs */
-      92, /* length */
-      95, /* substr */
-      98, /* vec */
-     100, /* index */
-     100, /* rindex */
+      95, /* length */
+      98, /* substr */
+     101, /* vec */
+     103, /* index */
+     103, /* rindex */
       52, /* sprintf */
       52, /* formline */
       75, /* ord */
       75, /* chr */
-      90, /* crypt */
+      93, /* crypt */
        0, /* ucfirst */
        0, /* lcfirst */
        0, /* uc */
        0, /* lc */
        0, /* quotemeta */
-     104, /* rv2av */
-     111, /* aelemfast */
-     111, /* aelemfast_lex */
-     112, /* aelem */
-     117, /* aslice */
-     120, /* kvaslice */
+     107, /* rv2av */
+     114, /* aelemfast */
+     114, /* aelemfast_lex */
+     115, /* aelem */
+     120, /* aslice */
+     123, /* kvaslice */
        0, /* aeach */
        0, /* avalues */
       40, /* akeys */
        0, /* each */
       40, /* values */
       40, /* keys */
-     121, /* delete */
-     125, /* exists */
-     127, /* rv2hv */
-     112, /* helem */
-     117, /* hslice */
-     120, /* kvhslice */
-     135, /* multideref */
+     124, /* delete */
+     128, /* exists */
+     130, /* rv2hv */
+     115, /* helem */
+     120, /* hslice */
+     123, /* kvhslice */
+     138, /* multideref */
       52, /* unpack */
       52, /* pack */
-     142, /* split */
+     145, /* split */
       52, /* join */
-     147, /* list */
+     150, /* list */
       12, /* lslice */
       52, /* anonlist */
       52, /* anonhash */
       52, /* splice */
-      90, /* push */
+      93, /* push */
        0, /* pop */
        0, /* shift */
-      90, /* unshift */
-     149, /* sort */
-     156, /* reverse */
+      93, /* unshift */
+     152, /* sort */
+     159, /* reverse */
        0, /* grepstart */
-     158, /* grepwhile */
+     161, /* grepwhile */
        0, /* mapstart */
        0, /* mapwhile */
        0, /* range */
-     160, /* flip */
-     160, /* flop */
+     163, /* flip */
+     163, /* flop */
        0, /* and */
        0, /* or */
       12, /* xor */
        0, /* dor */
-     162, /* cond_expr */
+     165, /* cond_expr */
        0, /* andassign */
        0, /* orassign */
        0, /* dorassign */
-     164, /* entersub */
-     171, /* leavesub */
-     171, /* leavesublv */
+     167, /* entersub */
+     174, /* leavesub */
+     174, /* leavesublv */
        0, /* argcheck */
-     173, /* argelem */
+     176, /* argelem */
        0, /* argdefelem */
-     175, /* caller */
+     178, /* caller */
       52, /* warn */
       52, /* die */
       52, /* reset */
       -1, /* lineseq */
-     177, /* nextstate */
-     177, /* dbstate */
+     180, /* nextstate */
+     180, /* dbstate */
       -1, /* unstack */
       -1, /* enter */
-     178, /* leave */
+     181, /* leave */
       -1, /* scope */
-     180, /* enteriter */
-     184, /* iter */
+     183, /* enteriter */
+     187, /* iter */
       -1, /* enterloop */
-     185, /* leaveloop */
+     188, /* leaveloop */
       -1, /* return */
-     187, /* last */
-     187, /* next */
-     187, /* redo */
-     187, /* dump */
-     187, /* goto */
+     190, /* last */
+     190, /* next */
+     190, /* redo */
+     190, /* dump */
+     190, /* goto */
       52, /* exit */
        0, /* method */
        0, /* method_named */
@@ -2679,7 +2681,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
        0, /* leavewhen */
       -1, /* break */
       -1, /* continue */
-     189, /* open */
+     192, /* open */
       52, /* close */
       52, /* pipe_op */
       52, /* fileno */
@@ -2695,7 +2697,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       52, /* getc */
       52, /* read */
       52, /* enterwrite */
-     171, /* leavewrite */
+     174, /* leavewrite */
       -1, /* prtf */
       -1, /* print */
       -1, /* say */
@@ -2709,7 +2711,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       52, /* truncate */
       52, /* fcntl */
       52, /* ioctl */
-      90, /* flock */
+      93, /* flock */
       52, /* send */
       52, /* recv */
       52, /* socket */
@@ -2725,44 +2727,44 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
        0, /* getpeername */
        0, /* lstat */
        0, /* stat */
-     194, /* ftrread */
-     194, /* ftrwrite */
-     194, /* ftrexec */
-     194, /* fteread */
-     194, /* ftewrite */
-     194, /* fteexec */
-     199, /* ftis */
-     199, /* ftsize */
-     199, /* ftmtime */
-     199, /* ftatime */
-     199, /* ftctime */
-     199, /* ftrowned */
-     199, /* fteowned */
-     199, /* ftzero */
-     199, /* ftsock */
-     199, /* ftchr */
-     199, /* ftblk */
-     199, /* ftfile */
-     199, /* ftdir */
-     199, /* ftpipe */
-     199, /* ftsuid */
-     199, /* ftsgid */
-     199, /* ftsvtx */
-     199, /* ftlink */
-     199, /* fttty */
-     199, /* fttext */
-     199, /* ftbinary */
-      90, /* chdir */
-      90, /* chown */
+     197, /* ftrread */
+     197, /* ftrwrite */
+     197, /* ftrexec */
+     197, /* fteread */
+     197, /* ftewrite */
+     197, /* fteexec */
+     202, /* ftis */
+     202, /* ftsize */
+     202, /* ftmtime */
+     202, /* ftatime */
+     202, /* ftctime */
+     202, /* ftrowned */
+     202, /* fteowned */
+     202, /* ftzero */
+     202, /* ftsock */
+     202, /* ftchr */
+     202, /* ftblk */
+     202, /* ftfile */
+     202, /* ftdir */
+     202, /* ftpipe */
+     202, /* ftsuid */
+     202, /* ftsgid */
+     202, /* ftsvtx */
+     202, /* ftlink */
+     202, /* fttty */
+     202, /* fttext */
+     202, /* ftbinary */
+      93, /* chdir */
+      93, /* chown */
       75, /* chroot */
-      90, /* unlink */
-      90, /* chmod */
-      90, /* utime */
-      90, /* rename */
-      90, /* link */
-      90, /* symlink */
+      93, /* unlink */
+      93, /* chmod */
+      93, /* utime */
+      93, /* rename */
+      93, /* link */
+      93, /* symlink */
        0, /* readlink */
-      90, /* mkdir */
+      93, /* mkdir */
       75, /* rmdir */
       52, /* open_dir */
        0, /* readdir */
@@ -2771,22 +2773,22 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
        0, /* rewinddir */
        0, /* closedir */
       -1, /* fork */
-     203, /* wait */
-      90, /* waitpid */
-      90, /* system */
-      90, /* exec */
-      90, /* kill */
-     203, /* getppid */
-      90, /* getpgrp */
-      90, /* setpgrp */
-      90, /* getpriority */
-      90, /* setpriority */
-     203, /* time */
+     206, /* wait */
+      93, /* waitpid */
+      93, /* system */
+      93, /* exec */
+      93, /* kill */
+     206, /* getppid */
+      93, /* getpgrp */
+      93, /* setpgrp */
+      93, /* getpriority */
+      93, /* setpriority */
+     206, /* time */
       -1, /* tms */
        0, /* localtime */
       52, /* gmtime */
        0, /* alarm */
-      90, /* sleep */
+      93, /* sleep */
       52, /* shmget */
       52, /* shmctl */
       52, /* shmread */
@@ -2801,8 +2803,8 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
        0, /* require */
        0, /* dofile */
       -1, /* hintseval */
-     204, /* entereval */
-     171, /* leaveeval */
+     207, /* entereval */
+     174, /* leaveeval */
        0, /* entertry */
       -1, /* leavetry */
        0, /* ghbyname */
@@ -2840,18 +2842,18 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
        0, /* lock */
        0, /* once */
       -1, /* custom */
-     210, /* coreargs */
-     214, /* avhvswitch */
+     213, /* coreargs */
+     217, /* avhvswitch */
        3, /* runcv */
        0, /* fc */
       -1, /* padcv */
       -1, /* introcv */
       -1, /* clonecv */
-     216, /* padrange */
-     218, /* refassign */
-     224, /* lvref */
-     230, /* lvrefslice */
-     231, /* lvavref */
+     219, /* padrange */
+     221, /* refassign */
+     227, /* lvref */
+     233, /* lvrefslice */
+     234, /* lvavref */
        0, /* anonconst */
 
 };
@@ -2872,74 +2874,75 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
 
 EXTCONST U16  PL_op_private_bitdefs[] = {
     0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */
-    0x2f3c, 0x4039, /* pushmark */
+    0x2f3c, 0x4119, /* pushmark */
     0x00bd, /* wantarray, runcv */
-    0x0578, 0x19b0, 0x40ec, 0x3ba8, 0x3385, /* const */
-    0x2f3c, 0x34d9, /* gvsv */
+    0x0578, 0x19b0, 0x41cc, 0x3c88, 0x3465, /* const */
+    0x2f3c, 0x35b9, /* gvsv */
     0x1815, /* gv */
     0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */
-    0x2f3c, 0x4038, 0x03d7, /* padsv */
-    0x2f3c, 0x4038, 0x06f4, 0x302c, 0x3d29, /* padav */
-    0x2f3c, 0x4038, 0x06f4, 0x0790, 0x302c, 0x3d28, 0x2aa1, /* padhv */
-    0x2f3c, 0x1b98, 0x03d6, 0x302c, 0x32a8, 0x40e4, 0x0003, /* rv2gv */
-    0x2f3c, 0x34d8, 0x03d6, 0x40e4, 0x0003, /* rv2sv */
+    0x2f3c, 0x4118, 0x03d7, /* padsv */
+    0x2f3c, 0x4118, 0x06f4, 0x302c, 0x3e09, /* padav */
+    0x2f3c, 0x4118, 0x06f4, 0x0790, 0x302c, 0x3e08, 0x2aa1, /* padhv */
+    0x2f3c, 0x1b98, 0x03d6, 0x302c, 0x3388, 0x41c4, 0x0003, /* rv2gv */
+    0x2f3c, 0x35b8, 0x03d6, 0x41c4, 0x0003, /* rv2sv */
     0x302c, 0x0003, /* av2arylen, akeys, values, keys */
-    0x321c, 0x0fd8, 0x0d34, 0x028c, 0x43e8, 0x40e4, 0x0003, /* rv2cv */
+    0x32fc, 0x0fd8, 0x0d34, 0x028c, 0x44c8, 0x41c4, 0x0003, /* rv2cv */
     0x06f4, 0x0790, 0x0003, /* ref */
     0x018f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
-    0x36bc, 0x35d8, 0x27f4, 0x2730, 0x0003, /* backtick */
+    0x379c, 0x36b8, 0x27f4, 0x2730, 0x0003, /* backtick */
     0x06f5, /* subst */
-    0x10dc, 0x2118, 0x0914, 0x3e6c, 0x24a8, 0x01e4, 0x0141, /* trans, transr */
+    0x10dc, 0x2118, 0x0914, 0x3f4c, 0x24a8, 0x01e4, 0x0141, /* trans, transr */
     0x0f1c, 0x0618, 0x0067, /* sassign */
     0x0bd8, 0x0ad4, 0x09d0, 0x302c, 0x06e8, 0x0067, /* aassign */
-    0x4490, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir */
+    0x4570, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir */
     0x06f4, 0x302c, 0x0003, /* pos */
-    0x4490, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
+    0x4570, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */
     0x1498, 0x0067, /* repeat */
-    0x2f3c, 0x0358, 0x1b94, 0x4490, 0x41cc, 0x0003, /* multiconcat */
-    0x4490, 0x018f, /* stringify, atan2, rand, srand, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
-    0x06f4, 0x4490, 0x0003, /* length */
-    0x3910, 0x302c, 0x012b, /* substr */
+    0x3218, 0x4570, 0x0067, /* concat */
+    0x2f3c, 0x0358, 0x1b94, 0x4570, 0x42ac, 0x0003, /* multiconcat */
+    0x4570, 0x018f, /* stringify, atan2, rand, srand, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
+    0x06f4, 0x4570, 0x0003, /* length */
+    0x39f0, 0x302c, 0x012b, /* substr */
     0x302c, 0x0067, /* vec */
-    0x3198, 0x06f4, 0x4490, 0x018f, /* index, rindex */
-    0x2f3c, 0x34d8, 0x06f4, 0x302c, 0x3d28, 0x40e4, 0x0003, /* rv2av */
+    0x3198, 0x06f4, 0x4570, 0x018f, /* index, rindex */
+    0x2f3c, 0x35b8, 0x06f4, 0x302c, 0x3e08, 0x41c4, 0x0003, /* rv2av */
     0x025f, /* aelemfast, aelemfast_lex */
     0x2f3c, 0x2e38, 0x03d6, 0x302c, 0x0067, /* aelem, helem */
-    0x2f3c, 0x302c, 0x3d29, /* aslice, hslice */
+    0x2f3c, 0x302c, 0x3e09, /* aslice, hslice */
     0x302d, /* kvaslice, kvhslice */
-    0x2f3c, 0x3c78, 0x2b54, 0x0003, /* delete */
-    0x4318, 0x0003, /* exists */
-    0x2f3c, 0x34d8, 0x06f4, 0x0790, 0x302c, 0x3d28, 0x40e4, 0x2aa1, /* rv2hv */
-    0x2f3c, 0x2e38, 0x1154, 0x1ab0, 0x302c, 0x40e4, 0x0003, /* multideref */
-    0x2f3c, 0x34d8, 0x0430, 0x2c4c, 0x2569, /* split */
+    0x2f3c, 0x3d58, 0x2b54, 0x0003, /* delete */
+    0x43f8, 0x0003, /* exists */
+    0x2f3c, 0x35b8, 0x06f4, 0x0790, 0x302c, 0x3e08, 0x41c4, 0x2aa1, /* rv2hv */
+    0x2f3c, 0x2e38, 0x1154, 0x1ab0, 0x302c, 0x41c4, 0x0003, /* multideref */
+    0x2f3c, 0x35b8, 0x0430, 0x2c4c, 0x2569, /* split */
     0x2f3c, 0x21d9, /* list */
-    0x45fc, 0x3f58, 0x13f0, 0x288c, 0x3a08, 0x2984, 0x3441, /* sort */
+    0x46dc, 0x4038, 0x13f0, 0x288c, 0x3ae8, 0x2984, 0x3521, /* sort */
     0x288c, 0x0003, /* reverse */
     0x06f4, 0x0003, /* grepwhile */
     0x2cd8, 0x0003, /* flip, flop */
     0x2f3c, 0x0003, /* cond_expr */
-    0x2f3c, 0x0fd8, 0x03d6, 0x028c, 0x43e8, 0x40e4, 0x2641, /* entersub */
-    0x3778, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+    0x2f3c, 0x0fd8, 0x03d6, 0x028c, 0x44c8, 0x41c4, 0x2641, /* entersub */
+    0x3858, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
     0x02aa, 0x0003, /* argelem */
     0x00bc, 0x018f, /* caller */
     0x23b5, /* nextstate, dbstate */
-    0x2ddc, 0x3779, /* leave */
-    0x2f3c, 0x34d8, 0x104c, 0x3a85, /* enteriter */
-    0x3a85, /* iter */
+    0x2ddc, 0x3859, /* leave */
+    0x2f3c, 0x35b8, 0x104c, 0x3b65, /* enteriter */
+    0x3b65, /* iter */
     0x2ddc, 0x0067, /* leaveloop */
-    0x471c, 0x0003, /* last, next, redo, dump, goto */
-    0x36bc, 0x35d8, 0x27f4, 0x2730, 0x018f, /* open */
+    0x47fc, 0x0003, /* last, next, redo, dump, goto */
+    0x379c, 0x36b8, 0x27f4, 0x2730, 0x018f, /* open */
     0x1d50, 0x1fac, 0x1e68, 0x1c24, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
     0x1d50, 0x1fac, 0x1e68, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
-    0x4491, /* wait, getppid, time */
-    0x3814, 0x0df0, 0x084c, 0x4568, 0x22c4, 0x0003, /* entereval */
+    0x4571, /* wait, getppid, time */
+    0x38f4, 0x0df0, 0x084c, 0x4648, 0x22c4, 0x0003, /* entereval */
     0x30fc, 0x0018, 0x1304, 0x1221, /* coreargs */
     0x302c, 0x00c7, /* avhvswitch */
     0x2f3c, 0x01fb, /* padrange */
-    0x2f3c, 0x4038, 0x04f6, 0x2a0c, 0x1908, 0x0067, /* refassign */
-    0x2f3c, 0x4038, 0x04f6, 0x2a0c, 0x1908, 0x0003, /* lvref */
+    0x2f3c, 0x4118, 0x04f6, 0x2a0c, 0x1908, 0x0067, /* refassign */
+    0x2f3c, 0x4118, 0x04f6, 0x2a0c, 0x1908, 0x0003, /* lvref */
     0x2f3d, /* lvrefslice */
-    0x2f3c, 0x4038, 0x0003, /* lvavref */
+    0x2f3c, 0x4118, 0x0003, /* lvavref */
 
 };
 
@@ -3014,7 +3017,7 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* I_ADD      */ (OPpARG2_MASK|OPpTARGET_MY),
     /* SUBTRACT   */ (OPpARG2_MASK|OPpTARGET_MY),
     /* I_SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY),
-    /* CONCAT     */ (OPpARG2_MASK|OPpTARGET_MY),
+    /* CONCAT     */ (OPpARG2_MASK|OPpTARGET_MY|OPpCONCAT_NESTED),
     /* MULTICONCAT */ (OPpARG1_MASK|OPpMULTICONCAT_STRINGIFY|OPpTARGET_MY|OPpMULTICONCAT_FAKE|OPpMULTICONCAT_APPEND|OPpLVAL_INTRO),
     /* STRINGIFY  */ (OPpARG4_MASK|OPpTARGET_MY),
     /* LEFT_SHIFT */ (OPpARG2_MASK|OPpTARGET_MY),
index e0a27f6..eb53edf 100644 (file)
@@ -807,6 +807,17 @@ for (qw(index rindex)) {
     addbits($_, 6 => qw(OPpINDEX_BOOLNEG NEG));
 }
 
+
+addbits('concat',
+    # OPf_STACKED normally indicates .=; but it also gets set to optimise
+    # $a . $b . $c into ($a . $b) .= $c
+    # so that the first concat's PADTMP (which holds the result of $a.$b)
+    # can be reused. Set a flag in this case to help deparse and warn
+    # distinguish the cases.
+    6 => qw(OPpCONCAT_NESTED NESTED),
+);
+
+
 addbits('multiconcat',
   # 7       OPpLVAL_INTRO
     6 => qw(OPpMULTICONCAT_APPEND APPEND), # $x .= ....
diff --git a/t/TEST b/t/TEST
index d564973..63f0c36 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -747,8 +747,7 @@ EOT
        # Deparse? Should it have passed or failed?
        if ($type eq 'deparse' && $test =~ $deparse_failures) {
            if (!$failure) {
-               # Wait, it didn't fail? Great news! Tell someone!
-               $failure = "FAILED--all tests passed but test should have failed";
+               # Wait, it didn't fail? Great news!
                push @unexpected_pass, $test;
            } else {
                # Bah, still failing. Mask it.