This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] lots of Deparse.pm fixups
authorDavid Mitchell <davem@iabyn.com>
Mon, 5 Jun 2017 13:33:09 +0000 (14:33 +0100)
committerDavid Mitchell <davem@iabyn.com>
Mon, 5 Jun 2017 13:33:09 +0000 (14:33 +0100)
As of this point,

    ./TEST -deparse op/delete.t

passes all tests (that are no on its exclude list)/

Porting/deparse-skips.txt
lib/B/Deparse.pm
lib/B/Deparse.t
t/TEST

index efac18f..130fcaa 100644 (file)
 
 __DEPARSE_FAILURES__
 
-../cpan/Scalar-List-Utils/t/proto.t
-../cpan/Term-ANSIColor/t/taint/basic.t
-../cpan/autodie/t/internal.t
-../cpan/AutoLoader/t/01AutoLoader.t
-../cpan/CGI/t/utf8.t
-../cpan/ExtUtils-MakeMaker/t/xs.t
-../cpan/File-Path/t/taint.t
-../cpan/Module-Build/t/manifypods_with_utf8.t
-../cpan/Socket/t/sockaddr.t
-../cpan/Term-ANSIColor/t/taint.t
-../cpan/Test-Simple/t/Builder/carp.t
-../cpan/Test-Simple/t/fail-more.t
-../cpan/Test-Simple/t/is_deeply_fail.t
-../cpan/Test-Simple/t/plan.t
-../cpan/Test-Simple/t/plan_bad.t
-../cpan/Test-Simple/t/subtest/line_numbers.t
-../cpan/Test-Simple/t/subtest/predicate.t
-../cpan/autodie/t/00-load.t
+base/lex.t                # checks regexp stringification
+comp/final_line_num.t     # tests syntax error after BEGIN block
+comp/fold.t               # mutability of folded constants
+comp/parser.t             # crazy #line directives ==> shell syntax errors
+mro/basic_01_c3_utf8.t
+mro/basic_01_dfs_utf8.t
+mro/complex_c3_utf8.t
+mro/isarev.t
+mro/isarev_utf8.t
+op/attrhand.t             # Custom attrs ignored; also AH provides none
+op/caller.t
+op/each.t                 # utf8ness of deparsed strings
+op/goto.t
+op/gv.t                   # glob copy constants
+op/hexfp.t
+op/index.t
+op/join.t                 # mutability of folded constants
+op/length.t               # utf8ness of deparsed strings
+op/lexsub.t
+op/local.t
+op/lvref.t
+op/not.t
+op/overload_integer.t
+op/override.t
+op/pack.t
+op/postfixderef.t
+op/range.t
+op/readline.t
+op/srand.t
+op/sub_lval.t
+op/sub.t
+op/switch.t
+op/symbolcache.t
+op/taint.t
+op/vec.t
+op/warn.t
+op/write.t
+porting/globvar.t
+re/overload.t             # [perl #123385] %^H output
+re/pat_advanced.t         # [perl #123417]
+re/pat_rt_report.t        # malformed utf8 constant; also /\c@/ -> /\c\@/
+re/pat.t                  # [perl #90590]
+re/regexp_unicode_prop.t
+re/regex_sets.t
+re/reg_fold.t             # [perl #123385] %^H output
+re/rxcode.t               # checks regexp stringification
+re/subst.t
+run/switchd-78586.t       # -I on #! line is not deparsed
+run/switchI.t             # -I on #! line is not deparsed
+uni/attrs.t
+uni/bless.t
+uni/gv.t
+uni/labels.t
+uni/lex_utf8.t
+uni/method.t
+uni/package.t
+uni/parser.t
+uni/readline.t
+uni/select.t
+uni/stash.t
+uni/tie.t
+uni/universal.t
+uni/variables.t
+../cpan/Archive-Tar/t/03_file.t         # constant sub ref: FOO->()
 ../cpan/autodie/t/autodie.t
+../cpan/autodie/t/basic_exceptions.t
+../cpan/autodie/t/binmode.t
 ../cpan/autodie/t/blog_hints.t
 ../cpan/autodie/t/caller.t
 ../cpan/autodie/t/chmod.t
 ../cpan/autodie/t/chown.t
-../cpan/autodie/t/context.t
 ../cpan/autodie/t/context_lexical.t
+../cpan/autodie/t/context.t
 ../cpan/autodie/t/crickey.t
 ../cpan/autodie/t/dbmopen.t
 ../cpan/autodie/t/eval_error.t
@@ -63,80 +111,86 @@ __DEPARSE_FAILURES__
 ../cpan/autodie/t/exceptions.t
 ../cpan/autodie/t/exec.t
 ../cpan/autodie/t/filehandles.t
-../cpan/autodie/t/hints.t
+../cpan/autodie/t/fileno.t
 ../cpan/autodie/t/hints_insist.t
 ../cpan/autodie/t/hints_pod_examples.t
 ../cpan/autodie/t/hints_provider_does.t
 ../cpan/autodie/t/hints_provider_easy_does_it.t
 ../cpan/autodie/t/hints_provider_isa.t
+../cpan/autodie/t/hints.t
+../cpan/autodie/t/internal.t
 ../cpan/autodie/t/kill.t
 ../cpan/autodie/t/lethal.t
+../cpan/autodie/t/mkdir.t
 ../cpan/autodie/t/open.t
+../cpan/autodie/t/read.t
 ../cpan/autodie/t/recv.t
 ../cpan/autodie/t/repeat.t
 ../cpan/autodie/t/scope_leak.t
 ../cpan/autodie/t/sysopen.t
+../cpan/autodie/t/truncate.t
+../cpan/autodie/t/unlink.t
 ../cpan/autodie/t/user-context.t
 ../cpan/autodie/t/usersub.t
 ../cpan/autodie/t/utf8_open.t
 ../cpan/autodie/t/utime.t
 ../cpan/autodie/t/version_tag.t
-../cpan/podlators/t/basic.t
+../cpan/AutoLoader/t/01AutoLoader.t
+../cpan/bignum/t/big_e_pi.t
+../cpan/bignum/t/bigexp.t
+../cpan/bignum/t/bigint.t
+../cpan/bignum/t/bignum.t
+../cpan/bignum/t/bigrat.t
+../cpan/bignum/t/bii_e_pi.t
+../cpan/bignum/t/biinfnan.t
+../cpan/bignum/t/bir_e_pi.t
+../cpan/bignum/t/bninfnan.t
+../cpan/bignum/t/brinfnan.t
+../cpan/bignum/t/in_effect.t
+../cpan/bignum/t/option_a.t
+../cpan/bignum/t/option_l.t
+../cpan/bignum/t/option_p.t
+../cpan/bignum/t/overrides.t
+../cpan/bignum/t/ratopt_a.t
+../cpan/bignum/t/scope_f.t
+../cpan/bignum/t/scope_i.t
+../cpan/bignum/t/scope_r.t
+../cpan/Math-BigInt/t/constant.t
+../cpan/Math-BigInt/t/const_mbf.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/plan_bad.t
+../cpan/Test-Simple/t/Legacy/plan.t
+../cpan/Test-Simple/t/Legacy/subtest/line_numbers.t
+../cpan/Test-Simple/t/Legacy/subtest/predicate.t
+../cpan/Test-Simple/t/regression/684-nested_todo_diag.t
+../cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t
 ../dist/Attribute-Handlers/t/constants.t
 ../dist/Attribute-Handlers/t/data_convert.t
 ../dist/Attribute-Handlers/t/linerep.t
 ../dist/Attribute-Handlers/t/multi.t
 ../dist/Carp/t/Carp.t
+../dist/constant/t/constant.t
 ../dist/Data-Dumper/t/dumper.t
+../dist/Data-Dumper/t/trailing_comma.t
 ../dist/Exporter/t/Exporter.t
 ../dist/Filter-Simple/t/data.t
-../dist/IO/t/io_file_export.t
-../dist/IO/t/io_multihomed.t
 ../dist/IO/t/io_sel.t
-../dist/IO/t/io_udp.t
-../dist/Locale-Maketext/t/01_about_verbose.t
-../dist/Locale-Maketext/t/10_make.t
-../dist/Locale-Maketext/t/20_get.t
-../dist/Locale-Maketext/t/40_super.t
-../dist/Locale-Maketext/t/50_super.t
-../dist/Locale-Maketext/t/60_super.t
-../dist/Locale-Maketext/t/70_fail_auto.t
-../dist/Locale-Maketext/t/91_backslash.t
-../dist/Math-BigInt/t/const_mbf.t
-../dist/Math-BigInt/t/constant.t
 ../dist/PathTools/t/cwd.t
 ../dist/Storable/t/blessed.t
 ../dist/Storable/t/croak.t
-../dist/Thread-Queue/t/08_nothreads.t
-../dist/bignum/t/big_e_pi.t
-../dist/bignum/t/bigexp.t
-../dist/bignum/t/bigint.t
-../dist/bignum/t/bignum.t
-../dist/bignum/t/bigrat.t
-../dist/bignum/t/bii_e_pi.t
-../dist/bignum/t/bir_e_pi.t
-../dist/bignum/t/in_effect.t
-../dist/bignum/t/option_a.t
-../dist/bignum/t/option_l.t
-../dist/bignum/t/option_p.t
-../dist/bignum/t/overrides.t
-../dist/bignum/t/ratopt_a.t
-../dist/bignum/t/scope_f.t
-../dist/bignum/t/scope_i.t
-../dist/bignum/t/scope_r.t
-../dist/constant/t/constant.t
-../dist/threads/t/err.t
-../dist/threads/t/exit.t
-../dist/threads/t/kill2.t
-../dist/threads/t/libc.t
-../dist/threads/t/thread.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/File-Glob/t/taint.t
-../ext/Hash-Util/t/Util.t
 ../ext/IPC-Open3/t/IPC-Open2.t
 ../ext/IPC-Open3/t/IPC-Open3.t
 ../ext/XS-APItest/t/autoload.t
@@ -145,70 +199,13 @@ __DEPARSE_FAILURES__
 ../ext/XS-APItest/t/cleanup.t
 ../ext/XS-APItest/t/fetch_pad_names.t
 ../ext/XS-APItest/t/svpeek.t
-../lib/DB.t
-../lib/English.t
-../lib/File/Basename.t
+../ext/XS-APItest/t/synthetic_scope.t
+../lib/Benchmark.t
 ../lib/charnames.t
+../lib/dumpvar.t
+../lib/English.t
 ../lib/overload.t
-base/lex.t                # checks regexp stringification
-comp/final_line_num.t     # tests syntax error after BEGIN block
-comp/fold.t               # mutability of folded constants
-comp/parser.t             # crazy #line directives ==> shell syntax errors
-mro/isarev.t
-mro/isarev_utf8.t
-op/attrhand.t             # Custom attrs ignored; also AH provides none
-op/attrs.t                # [perl #70205] my attrs
-op/caller.t
-op/each.t                 # utf8ness of deparsed strings
-op/getpid.t               # [perl #70205] my attrs
-op/goto.t
-op/gv.t                   # glob copy constants
-op/index.t
-op/join.t                 # mutability of folded constants
-op/length.t               # utf8ness of deparsed strings
-op/lexsub.t
-op/local.t
-op/not.t
-op/overload_integer.t
-op/override.t
-op/pack.t
-op/postfixderef.t
-op/range.t
-op/readline.t
-op/srand.t
-op/sub.t
-op/sub_lval.t
-op/switch.t
-op/symbolcache.t
-op/taint.t
-op/vec.t
-op/warn.t
-op/write.t
-porting/globvar.t
-re/overload.t             # [perl #123385] %^H output
-re/pat.t                  # [perl #90590]
-re/pat_advanced.t         # [perl #123417]
-re/pat_rt_report.t        # malformed utf8 constant; also /\c@/ -> /\c\@/
-re/reg_fold.t             # [perl #123385] %^H output
-re/regex_sets.t
-re/regexp_unicode_prop.t
-re/rxcode.t               # checks regexp stringification
-re/subst.t
-run/switchI.t             # -I on #! line is not deparsed
-run/switchd-78586.t       # -I on #! line is not deparsed
-uni/attrs.t
-uni/bless.t
-uni/gv.t
-uni/labels.t
-uni/lex_utf8.t
-uni/method.t
-uni/package.t
-uni/parser.t
-uni/readline.t
-uni/select.t
-uni/stash.t
-uni/tie.t
-uni/universal.t
+
 
 __DEPARSE_SKIPS__
 
index 6c35a72..b22683a 100644 (file)
@@ -12,7 +12,8 @@ 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 OPf_PARENS
-        OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+        OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE
+         OPpCONST_BARE
         OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
         OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
         OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
@@ -362,7 +363,8 @@ BEGIN {
 
 
 BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
-                nextstate dbstate rv2av rv2hv helem custom ]) {
+                kvaslice kvhslice
+                 nextstate dbstate rv2av rv2hv helem custom ]) {
     eval "sub OP_\U$_ () { " . opnumber($_) . "}"
 }}
 
@@ -402,13 +404,27 @@ sub _pessimise_walk {
 
        # pessimisations end here
 
-       if (class($op) eq 'PMOP'
-           && ref($op->pmreplroot)
-           && ${$op->pmreplroot}
-           && $op->pmreplroot->isa( 'B::OP' ))
-       {
-           $self-> _pessimise_walk($op->pmreplroot);
-       }
+       if (class($op) eq 'PMOP') {
+           if (ref($op->pmreplroot)
+                && ${$op->pmreplroot}
+                && $op->pmreplroot->isa( 'B::OP' ))
+            {
+                $self-> _pessimise_walk($op->pmreplroot);
+            }
+
+            # pessimise any /(?{...})/ code blocks
+            my ($re, $cv);
+            my $code_list = $op->code_list;
+            if ($$code_list) {
+                $self->_pessimise_walk($code_list);
+            }
+            elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) {
+                $code_list = $cv->ROOT      # leavesub
+                               ->first      #   qr
+                               ->code_list; #     list
+                $self->_pessimise_walk($code_list);
+            }
+        }
 
        if ($op->flags & OPf_KIDS) {
            $self-> _pessimise_walk($op->first);
@@ -424,6 +440,8 @@ sub _pessimise_walk {
 sub _pessimise_walk_exe {
     my ($self, $startop, $visited) = @_;
 
+    no warnings 'recursion';
+
     return unless $$startop;
     return if $visited->{$$startop};
     my ($op, $prevop);
@@ -558,7 +576,17 @@ sub next_todo {
                 #  makes use of a lexical var that's not in scope.
                 #  So strip it out.
                 return $pragmata
-                            if $use_dec =~ /^use \S+ \(@\{\$args\[0\];\}\);/;
+                        if $use_dec =~
+                            m/
+                                \A
+                                use \s \S+ \s \(\@\{
+                                (
+                                    \s*\#line\ \d+\ \".*"\s*
+                                )?
+                                \$args\[0\];\}\);
+                                \n
+                                \Z
+                            /x;
 
                $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
            }
@@ -612,6 +640,9 @@ sub begin_is_use {
     my $req_op = $lineseq->first->sibling;
     return if $req_op->name ne "require";
 
+    # maybe it's C<require expr> rather than C<require 'foo'>
+    return if ($req_op->first->name ne 'const');
+
     my $module;
     if ($req_op->first->private & OPpCONST_BARE) {
        # Actually it should always be a bareword
@@ -2648,7 +2679,7 @@ sub pp_delete {
     my($op, $cx) = @_;
     my $arg;
     my $name = $self->keyword("delete");
-    if ($op->private & OPpSLICE) {
+    if ($op->private & (OPpSLICE|OPpKVSLICE)) {
        if ($op->flags & OPf_SPECIAL) {
            # Deleting from an array, not a hash
            return $self->maybe_parens_func($name,
@@ -3516,9 +3547,167 @@ BEGIN {
     delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
 }
 
+
+# Look for a my 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:
+#
+# my $x :foo;
+#      <1> ex-list vK/LVINTRO ->c
+#         <0> ex-pushmark v ->3
+#         <1> entersub[t2] vKRS*/TARG ->b
+#                ....
+#         <0> padsv[$x:64,65] vM/LVINTRO ->c
+#
+# my @a :foo;
+# my %h :foo;
+#
+#      <1> ex-list vK ->c
+#         <0> ex-pushmark v ->3
+#         <0> padav[@a:64,65] vM/LVINTRO ->4
+#         <1> entersub[t2] vKRS*/TARG ->c
+#            ....
+#
+# my ($x,@a,%h) :foo;
+#
+#      <;> nextstate(main 64 -e:1) v:{ ->3
+#      <@> list vKP ->w
+#         <0> pushmark vM/LVINTRO ->4
+#         <0> padsv[$x:64,65] vM/LVINTRO ->5
+#         <0> padav[@a:64,65] vM/LVINTRO ->6
+#         <0> padhv[%h:64,65] vM/LVINTRO ->7
+#         <1> entersub[t4] vKRS*/TARG ->f
+#            ....
+#         <1> entersub[t5] vKRS*/TARG ->n
+#            ....
+#         <1> entersub[t6] vKRS*/TARG ->v
+#           ....
+# where the entersub in all cases looks like
+#        <1> entersub[t2] vKRS*/TARG ->c
+#           <0> pushmark s ->5
+#           <$> const[PV "attributes"] sM ->6
+#           <$> const[PV "main"] sM ->7
+#           <1> srefgen sKM/1 ->9
+#              <1> ex-list lKRM ->8
+#                 <0> padsv[@a:64,65] sRM ->8
+#           <$> const[PV "foo"] sM ->a
+#           <.> method_named[PV "import"] ->b
+
+sub maybe_my_attr {
+    my ($self, $op, $cx) = @_;
+
+    my $kid = $op->first->sibling; # skip pushmark
+    return if class($kid) eq 'NULL';
+
+    my $lop;
+    my $type;
+
+    # Extract out all the pad ops and entersub ops into
+    # @padops and @entersubops. Return if anything else seen.
+    # Also determine what class (if any) all the pad vars belong to
+    my $class;
+    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)
+                                ? $padname->SvSTASH->NAME : 'main';
+
+            # all pad vars must be in the same class
+            $class //= $thisclass;
+            return unless $thisclass eq $class;
+
+            push @padops, $lop;
+        }
+        elsif ($lopname eq 'entersub') {
+            push @entersubops, $lop;
+        }
+        else {
+            return;
+        }
+    }
+
+    return unless @padops && @padops == @entersubops;
+
+    # there should be a balance: each padop has a corresponding
+    # 'attributes'->import() method call, in the same order.
+
+    my @varnames;
+    my $attr_text;
+
+    for my $i (0..$#padops) {
+        my $padop = $padops[$i];
+        my $esop  = $entersubops[$i];
+
+        push @varnames, $self->padname($padop->targ);
+
+        return unless ($esop->flags & OPf_KIDS);
+
+        my $kid = $esop->first;
+        return unless $kid->type == OP_PUSHMARK;
+
+        $kid = $kid->sibling;
+        return unless $$kid && $kid->type == OP_CONST;
+       return unless $self->const_sv($kid)->PV eq 'attributes';
+
+        $kid = $kid->sibling;
+        return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__
+
+        $kid = $kid->sibling;
+        return unless  $$kid
+                    && $kid->name eq "srefgen"
+                    && ($kid->flags & OPf_KIDS)
+                    && ($kid->first->flags & OPf_KIDS)
+                    && $kid->first->first->name =~ /^pad[sah]v$/
+                    && $kid->first->first->targ == $padop->targ;
+
+        $kid = $kid->sibling;
+        my @attr;
+        while ($$kid) {
+            last if ($kid->type != OP_CONST);
+            push @attr, $self->const_sv($kid)->PV;
+            $kid = $kid->sibling;
+        }
+        return unless @attr;
+        my $thisattr = ":" . join(' ', @attr);
+        $attr_text //= $thisattr;
+        # all import calls must have the same list of attributes
+        return unless $attr_text eq $thisattr;
+
+        return unless $kid->name eq 'method_named';
+       return unless $self->meth_sv($kid)->PV eq 'import';
+
+        $kid = $kid->sibling;
+        return if $$kid;
+    }
+
+    my $res = 'my';
+    $res .= " $class " if $class ne 'main';
+    $res .=
+            (@varnames > 1)
+            ? "(" . join(', ', @varnames) . ')'
+            : " $varnames[0]";
+
+    return "$res $attr_text";
+}
+
+
 sub pp_list {
     my $self = shift;
     my($op, $cx) = @_;
+
+    {
+        # might be my ($s,@a,%h) :Foo(bar);
+        my $my_attr = maybe_my_attr($self, $op, $cx);
+        return $my_attr if defined $my_attr;
+    }
+
     my($expr, @exprs);
     my $kid = $op->first->sibling; # skip pushmark
     return '' if class($kid) eq 'NULL';
@@ -3812,6 +4001,13 @@ sub _op_is_or_was {
 
 sub pp_null {
     my($self, $op, $cx) = @_;
+
+    # might be 'my $s :Foo(bar);'
+    if ($op->targ == OP_LIST) {
+        my $my_attr = maybe_my_attr($self, $op, $cx);
+        return $my_attr if defined $my_attr;
+    }
+
     if (class($op) eq "OP") {
        # old value is lost
        return $self->{'ex_const'} if $op->targ == OP_CONST;
@@ -4319,8 +4515,9 @@ sub slice {
     } else {
        $list = $self->elem_or_slice_single_index($kid);
     }
-    my $lead = '@';
-    $lead = '%' if $op->name =~ /^kv/i;
+    my $lead = (   _op_is_or_was($op, OP_KVHSLICE)
+                || _op_is_or_was($op, OP_KVASLICE))
+               ? '%' : '@';
     return $lead . $array . $left . $list . $right;
 }
 
@@ -4807,11 +5004,33 @@ sub unback {
 
 # Remove backslashes which precede literal control characters,
 # to avoid creating ambiguity when we escape the latter.
+#
+# Don't remove a backslash from escaped whitespace: where the T represents
+# a literal tab character, /T/x is not equivalent to /\T/x
+
 sub re_unback {
     my($str) = @_;
 
     # the insane complexity here is due to the behaviour of "\c\"
-    $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
+    $str =~ s/
+                # these two lines ensure that the backslash we're about to
+                # remove isn't preceeded by something which makes it part
+                # of a \c
+
+                (^ | [^\\] | \\c\\)             # $1
+                (?<!\\c)
+
+                # the backslash to remove
+                \\
+
+                # keep pairs of backslashes
+                (\\\\)*                         # $2
+
+                # only remove if the thing following is a control char
+                (?=[[:^print:]])
+                # and not whitespace
+                (?=\S)
+            /$1$2/xg;
     return $str;
 }
 
index 7eeb4f8..57c523c 100644 (file)
@@ -63,7 +63,7 @@ while (<DATA>) {
            new B::Deparse split /,/, $meta{options}
        : $deparse;
 
-    my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
+    my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
 # Tell B::Deparse about our ambient pragmas
 my ($hint_bits, $warning_bits, $hinthash);
 BEGIN {
@@ -75,10 +75,14 @@ $deparse->ambient_pragmas (
     '%^H'        => $hinthash,
 );
 EOC
+    my $coderef = eval $code;
 
     local $::TODO = $meta{todo};
     if ($@) {
-       is($@, "", "compilation of $desc");
+       is($@, "", "compilation of $desc")
+            or diag "=============================================\n"
+                  . "CODE:\n--------\n$code\n--------\n"
+                  . "=============================================\n";
     }
     else {
        my $deparsed = $deparse->coderef2text( $coderef );
@@ -2610,3 +2614,50 @@ sub ($a, $=) {
     $a;
 }
 ;
+####
+# padrange op within pattern code blocks
+/(?{ my($x, $y) = (); })/;
+my $a;
+/$a(?{ my($x, $y) = (); })/;
+my $r1 = qr/(?{ my($x, $y) = (); })/;
+my $r2 = qr/$a(?{ my($x, $y) = (); })/;
+####
+# don't remove pattern whitespace escapes
+/a\ b/;
+/a\ b/x;
+/a\    b/;
+/a\    b/x;
+####
+# my attributes
+my $s1 :foo(f1, f2) bar(b1, b2);
+my @a1 :foo(f1, f2) bar(b1, b2);
+my %h1 :foo(f1, f2) bar(b1, b2);
+my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
+####
+# my class attributes
+package Foo::Bar;
+my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
+package main;
+my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2);
+####
+# avoid false positives in my $x :attribute
+'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1;
+'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2;
+####
+# hash slices and hash key/value slices
+my(@a, %h);
+our(@oa, %oh);
+@a = @h{'foo', 'bar'};
+@a = %h{'foo', 'bar'};
+@a = delete @h{'foo', 'bar'};
+@a = delete %h{'foo', 'bar'};
+@oa = @oh{'foo', 'bar'};
+@oa = %oh{'foo', 'bar'};
+@oa = delete @oh{'foo', 'bar'};
+@oa = delete %oh{'foo', 'bar'};
diff --git a/t/TEST b/t/TEST
index 6dc9587..8509b56 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -23,6 +23,8 @@ my $deparse_failures;
 # And skip even running these
 my $deparse_skips;
 
+my $deparse_skip_file = '../Porting/deparse-skips.txt';
+
 # directories with special sets of test switches
 my %dir_to_switch =
     (base => '',
@@ -562,6 +564,7 @@ EOT
     my $tested_files  = 0;
     my $totmax = 0;
     my %failed_tests;
+    my @unexpected_pass; # files where deparse-skips.txt says fail but passed
     my $toolnm;                # valgrind, cachegrind, perf
 
     while (my $test = shift @tests) {
@@ -715,6 +718,7 @@ EOT
            if (!$failure) {
                # Wait, it didn't fail? Great news! Tell someone!
                $failure = "FAILED--all tests passed but test should have failed";
+               push @unexpected_pass, $test;
            } else {
                # Bah, still failing. Mask it.
                print "${te}skipped\n";
@@ -774,6 +778,17 @@ EOT
        for my $test ( sort keys %failed_tests ) {
            print "\t$test\n";
        }
+
+       if (@unexpected_pass) {
+           print <<EOF;
+
+The following scripts were expected to fail under -deparse (at least
+according to $deparse_skip_file), but unexpectedly succeeded:
+EOF
+           print "\t$_\n" for sort @unexpected_pass;
+           print "\n";
+       }
+
        warn <<'SHRDLU_1';
 ### Since not all tests were successful, you may want to run some of
 ### them individually and examine any diagnostic messages they produce.
@@ -947,13 +962,12 @@ sub _cleanup_valgrind {
 }
 
 # Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
-my $in;
 
 sub _process_deparse_config {
     my @deparse_failures;
     my @deparse_skips;
 
-    my $f = '../Porting/deparse-skips.txt';
+    my $f = $deparse_skip_file;
 
     my $skips;
     if (!open($skips, '<', $f)) {
@@ -961,6 +975,7 @@ sub _process_deparse_config {
         return;
     }
 
+    my $in;
     while(<$skips>) {
         if (/__DEPARSE_FAILURES__/) {
             $in = \@deparse_failures; next;
@@ -976,6 +991,7 @@ sub _process_deparse_config {
         next unless $_;
 
         push @$in, $_;
+       warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
     }
 
     for my $f (@deparse_failures, @deparse_skips) {