In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f21038656da352686689ac9b4c5197596eba771d?hp=8ecf5aeb0235fbd7428a9aa07025bd0631054e13>
- Log ----------------------------------------------------------------- commit f21038656da352686689ac9b4c5197596eba771d Merge: 8ecf5aeb02 ac1e5644d2 Author: David Mitchell <[email protected]> Date: Mon Jun 5 14:33:09 2017 +0100 [MERGE] lots of Deparse.pm fixups As of this point, ./TEST -deparse op/delete.t passes all tests (that are no on its exclude list)/ commit ac1e5644d2654804904c5c407c9a03f8fe69bc32 Author: David Mitchell <[email protected]> Date: Mon Jun 5 14:29:51 2017 +0100 Deparse: support delete %h{foo bar} Key/value slicing was recently extended to delete too. Make Deparse support this. M lib/B/Deparse.pm M lib/B/Deparse.t commit 09d973d9b43960af79211d9b8ae04a77c6fbf778 Author: David Mitchell <[email protected]> Date: Mon Feb 27 08:45:08 2017 +0000 Porting/deparse-skips.txt: add failing tests Add the 27 currently unexpected failing tests to the 'known failing' list in deparse-skips.txt. These most likely represent newer or modified test scripts which tickle existing Deparse issues rather than regressions in Deparse, but I haven't examined them to check. By adding them in, we're kind of resetting the clock - perhaps in future we won't allow new failures to appear. There are now 174 known failing scripts out of 2555. At the start of this branch there were 178 known failing and 84 unexpectedly failing scripts. In 5.24.0 there were 207 known failing and 174 unexpectedly failing scripts. Also, re-sort the list. The following were added to to deparse-skips.txt by this commit: ../cpan/Module-Metadata/t/metadata.t ../cpan/Scalar-List-Utils/t/subname.t ../cpan/Scalar-List-Utils/t/uniq.t ../cpan/Term-Cap/test.pl ../cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t ../cpan/Test-Simple/t/regression/684-nested_todo_diag.t ../cpan/autodie/t/basic_exceptions.t ../cpan/autodie/t/binmode.t ../cpan/autodie/t/fileno.t ../cpan/autodie/t/mkdir.t ../cpan/autodie/t/read.t ../cpan/autodie/t/truncate.t ../cpan/autodie/t/unlink.t ../cpan/bignum/t/biinfnan.t ../cpan/bignum/t/bninfnan.t ../cpan/bignum/t/brinfnan.t ../dist/Data-Dumper/t/trailing_comma.t ../dist/threads/t/blocks.t ../ext/XS-APItest/t/synthetic_scope.t ../lib/Benchmark.t ../lib/dumpvar.t mro/basic_01_c3_utf8.t mro/basic_01_dfs_utf8.t mro/complex_c3_utf8.t op/hexfp.t op/lvref.t uni/variables.t M Porting/deparse-skips.txt commit 629541b497d04a6c376755a6fb206519f4614091 Author: David Mitchell <[email protected]> Date: Fri Feb 24 20:25:18 2017 +0000 purge Porting/deparse-skips.txt Many excluded files have since been removed, and some have been renamed. Update Porting/deparse-skips.txt accordingly. M Porting/deparse-skips.txt commit 94021b253e6a3557d6e506f59c0278dd795899f6 Author: David Mitchell <[email protected]> Date: Fri Feb 24 20:15:48 2017 +0000 t/TEST: warn about unknown files deparse-skips.txt In ./TEST -deparse, when reading Porting/deparse-skips.txt, emit a warning for each excluded file which no longer exists. Also, move the scope of $in to just the sub that uses it. M t/TEST commit 2ac6acbfdb0279ee04042bba82091927148060a4 Author: David Mitchell <[email protected]> Date: Fri Feb 24 20:00:34 2017 +0000 deparse-skips.txt: remove cpan/File-Path/t/taint.t This was fixed a few commits ago, but I forgot to mark it fixed. M Porting/deparse-skips.txt commit daeb52b8cb1067f5896a0c93b1afd12a85d2c21e Author: David Mitchell <[email protected]> Date: Fri Feb 24 17:37:31 2017 +0000 deparse-skips.txt: add Archive-Tar/t/03_file.t This test script uses constant anon subs, which get deparsed back into real subs and fail; e.g. use strict; { my $x; use constant FOO => sub { $x = 1 }; } FOO->(); which gets deparsed as use strict; { my $x; use constant FOO => sub { $x = 1 }; } sub { $x = 1 }->(); and croaks with 'Global symbol "$x" requires explicit package name' Since the name of the constant ('FOO') has been folded away, there's no way to correctly deparse this unless more info is saved in the op tree. M Porting/deparse-skips.txt commit f19f3753c9ff41b99bd94699c215943a1b59d2ef Author: David Mitchell <[email protected]> Date: Fri Feb 24 17:35:57 2017 +0000 sort Porting/deparse-skips.txt have core test first, then cpan/dist etc. Sort alphabetically within each category M Porting/deparse-skips.txt commit 7a4a81c99a2e1dd2397d2007137a2290ddcdfb73 Author: David Mitchell <[email protected]> Date: Fri Feb 24 16:11:34 2017 +0000 Deparse: better handle BEGIN { use_ok() } Commit v5.25.3-111-g8071973 added handling for the bad deparsing of BEGIN { use_ok() } Basically by stripping out the bad code text *after* it had been deparsed. However, this didn't catch all bad cases - in particular, where #line directives got added: use Socket (@{ #line 10 "t/000_load.t" $args[0];}); Under TEST -deparse, this fixes the following unexpectedly failing scripts: ../cpan/Term-ANSIColor/t/taint/basic.t ../cpan/autodie/t/00-load.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 ../ext/File-Glob/t/taint.t ../ext/Hash-Util/t/Util.t ../lib/DB.t ../lib/File/Basename.t and fixes the following expected-to-fail script: ../dist/Net-Ping/t/000_load.t M Porting/deparse-skips.txt M lib/B/Deparse.pm commit 82ab48fa8c6c51b80c9b69419850061640110339 Author: David Mitchell <[email protected]> Date: Fri Feb 24 14:32:28 2017 +0000 Deparse my var attributes correctly Formerly this: my $x :foo; deparsed as 'attributes'->import('main', \$x, 'foo'), my $x; it now deparses as: my $x :foo; It handles all the common forms, such as my Foo::Bar ($s, @a, %h) :foo(foo1) bar(bar1); but doesn't yet handle an attribute declaration that's not a statement, e.g. f(1, $x :foo); Under TEST -deparse, this fixes the following unexpectedly failing scripts: ../dist/IO/t/io_file_export.t ../dist/IO/t/io_multihomed.t ../dist/IO/t/io_udp.t ../dist/Thread-Queue/t/02_refs.t ../dist/Thread-Semaphore/t/01_basic.t ../dist/Thread-Semaphore/t/04_nonblocking.t ../dist/Thread-Semaphore/t/05_force.t ../dist/Thread-Semaphore/t/06_timed.t ../dist/threads-shared/t/av_refs.t ../dist/threads-shared/t/blessed.t ../dist/threads-shared/t/clone.t ../dist/threads-shared/t/cond.t ../dist/threads-shared/t/dualvar.t ../dist/threads-shared/t/hv_refs.t ../dist/threads-shared/t/object.t ../dist/threads-shared/t/object2.t ../dist/threads-shared/t/shared_attr.t ../dist/threads-shared/t/sv_refs.t ../dist/threads-shared/t/utf8.t ../dist/threads-shared/t/wait.t ../dist/threads-shared/t/waithires.t ../dist/threads/t/err.t ../dist/threads/t/free.t ../dist/threads/t/join.t ../dist/threads/t/kill.t ../dist/threads/t/kill2.t ../dist/threads/t/libc.t ../dist/threads/t/problems.t ../dist/threads/t/state.t op/threads-dirh.t and fixes the following expected-to-fail scripts: ../dist/Thread-Queue/t/08_nothreads.t ../dist/threads/t/exit.t ../dist/threads/t/thread.t op/attrs.t op/getpid.t M Porting/deparse-skips.txt M lib/B/Deparse.pm M lib/B/Deparse.t commit 0a30b526db0a91f5cad699185aecc65e6eef7965 Author: David Mitchell <[email protected]> Date: Thu Feb 23 14:33:05 2017 +0000 Deparse.pm: handle BEGIN { require expr } Deparse examines BEGIN subs to see if they look like BEGIN { require Foo; ... } and if so deparses them as 'use Foo' instead. However, it can't cope when Foo is an expression rather than a constant, such as BEGIN { require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); } and crashes. This commit makes it instead recognise such op trees as not being part of a 'use'. Under TEST -deparse, this fixes the following unexpectedly failing script: dist/threads/t/kill3.t and fixes the following expected-to-fail scripts: dist/IO/t/io_file_export.t dist/IO/t/io_multihomed.t dist/IO/t/io_udp.t dist/threads/t/err.t dist/threads/t/kill2.t dist/threads/t/libc.t M Porting/deparse-skips.txt M lib/B/Deparse.pm commit f7f169a88ce4013295a6e0b5dc924e6d3b2d3aaa Author: David Mitchell <[email protected]> Date: Thu Feb 23 13:41:35 2017 +0000 Deparse: avoid deep recursion warning sub _pessimise_walk_exe() recursively walks the optree, so can easily exceed a depth of 100. M lib/B/Deparse.pm commit 10d904055cb202489bc6ddc7d583fd213a3a09b4 Author: David Mitchell <[email protected]> Date: Thu Feb 23 12:52:09 2017 +0000 t/TEST -deparse: list unexpectedly passing scripts Currently Porting/deparse-skips.txt maintains a list of test scripts that are expected fail when run after deparsing. If a script unexpectedly passes, its listed as a failure in the summary at the end of the run. Make the summary include a list of unexpected passes too to make it easier to distinguish from failures. M t/TEST commit 4d7ac81a3c0ccb379bb5cb05d2c845b706f7289b Author: David Mitchell <[email protected]> Date: Thu Feb 23 10:53:10 2017 +0000 Deparse: don't remove escapes for tabs in patterns In the following, the T represents a literal tab character. /\T/ and /\T/x were being deparsed as /T/ and /T/x. In the particular case of /\T/x that actually changed the pattern's meaning. So don't do that: leave the backslashes alone. This makes ./TEST -deparse t/re/keep_tabs.t pass. M lib/B/Deparse.pm M lib/B/Deparse.t commit 27daf5669559d9755c5886825536aefd01d540ca Author: David Mitchell <[email protected]> Date: Thu Feb 23 10:30:42 2017 +0000 Deparse: make a complex pattern readable with /x In sub re_unback(). It shouldn't change its functionality, but just add whitespace and comments for readability. M lib/B/Deparse.pm commit b814db6746bca3ed76b5713debbbb44901168a1f Author: David Mitchell <[email protected]> Date: Wed Feb 22 16:54:51 2017 +0000 Deparse: handle OP_PADRANGE in regex code blocks Deparse handles the OP_PADRANGE op by overlaying the view of the optree with the original pad ops (as if they had never been optimised into a single OP_PADRANGE op). However, the op treewalk to pessimise such ops wasn't walking into the op subtrees of code blocks in patterns. So for example /(?{ my ($x, $y) = @a; })/ was being deparsed (with a warning) as /(?{ (XXX) = @a; })/ With this commit, this passes again: ./TEST -deparse re/pat_re_eval.t M lib/B/Deparse.pm M lib/B/Deparse.t commit 27cbbc57af5b2f37beb0725e483bf78e9f9f1901 Author: David Mitchell <[email protected]> Date: Wed Feb 22 16:53:50 2017 +0000 Deparse.t: diag full code that failed to compile makes it easier to debug when adding new tests that it doesn't like M lib/B/Deparse.t ----------------------------------------------------------------------- Summary of changes: Porting/deparse-skips.txt | 239 ++++++++++++++++++++++---------------------- lib/B/Deparse.pm | 247 +++++++++++++++++++++++++++++++++++++++++++--- lib/B/Deparse.t | 55 ++++++++++- t/TEST | 20 +++- 4 files changed, 422 insertions(+), 139 deletions(-) diff --git a/Porting/deparse-skips.txt b/Porting/deparse-skips.txt index efac18fb0b..130fcaaff2 100644 --- a/Porting/deparse-skips.txt +++ b/Porting/deparse-skips.txt @@ -31,31 +31,79 @@ __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__ diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 6c35a7275e..b22683ac49 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -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; } diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 7eeb4f813b..57c523c6cb 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -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 6dc958791c..8509b5659a 100755 --- 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) { -- Perl5 Master Repository
