In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b68108d9b5245170bc0844ad4bded511ab7cca6a?hp=70ce046ea7ef87cf6b0c748a062f750f4ad8fc8f>
- Log ----------------------------------------------------------------- commit b68108d9b5245170bc0844ad4bded511ab7cca6a Author: Father Chrysostomos <[email protected]> Date: Fri Oct 12 22:29:04 2012 -0700 Handle cow $_ in @INC filter Setting $_ to a copy-on-write scalar in an @INC filter causes the parser to modify every other scalar sharing the same string buffer. It needs to be forced to a regular scalar before the parser sees it. M pp_ctl.c M t/op/incfilter.t commit 2203fb5a8b3178b6188538e4c811106ceb721132 Author: Father Chrysostomos <[email protected]> Date: Fri Oct 12 21:59:47 2012 -0700 Allow COW copies in aassign When the âno common varsâ optimisation is not active, list assignment does not allow COW copies (unless assigning to an empty hash or array). It has been this way since 61e5f455dc. The recent addition of sv_mortalcopy_flags gives us an easy way to fix this. A certain test in tr.t was marked TODO if not given a COW. This test used to pass before 61e5f455dc, but after than becaming a failing TODO test. It makes sense to test that we do have a COW instead of having a conditional TODO. M pp_hot.c M t/op/tr.t ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 1 + pp_hot.c | 8 +++++--- t/op/incfilter.t | 7 ++++++- t/op/tr.t | 6 +++--- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 23847c4..1aaa261 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -5383,6 +5383,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) LEAVE_with_name("call_filter_sub"); } + if (SvIsCOW(upstream)) sv_force_normal(upstream); if(!err && SvOK(upstream)) { got_p = SvPV(upstream, got_len); if (umaxlen) { diff --git a/pp_hot.c b/pp_hot.c index 7994992..9d28855 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -955,9 +955,11 @@ PP(pp_aassign) Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p", (void*)sv); } - /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs, - and we need a second copy of a temp here. */ - *relem = sv_2mortal(newSVsv(sv)); + /* Not newSVsv(), as it does not allow copy-on-write, + resulting in wasteful copies. We need a second copy of + a temp here, hence the SV_NOSTEAL. */ + *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV + |SV_NOSTEAL); } } } diff --git a/t/op/incfilter.t b/t/op/incfilter.t index 582b691..6227c4a 100644 --- a/t/op/incfilter.t +++ b/t/op/incfilter.t @@ -13,7 +13,7 @@ use strict; use Config; use Filter::Util::Call; -plan(tests => 144); +plan(tests => 145); unshift @INC, sub { no warnings 'uninitialized'; @@ -216,6 +216,11 @@ do [\'pa', \&generator_with_state, "pass('And return multiple lines');\n", ]] or die; +@origlines = keys %{{ "1\n+\n2\n" => 1 }}; +@lines = @origlines; +do \&generator or die; +is $origlines[0], "1\n+\n2\n", 'ink filters do not mangle cow buffers'; + # d8723a6a74b2c12e wasn't perfect, as the char * returned by SvPV*() can be # a temporary, freed at the next FREETMPS. And there is a FREETMPS in # pp_require diff --git a/t/op/tr.t b/t/op/tr.t index 61f570c..41746fc 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -8,7 +8,7 @@ BEGIN { require './test.pl'; } -plan tests => 131; +plan tests => 132; my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); @@ -486,9 +486,9 @@ is($s, "AxBC", "utf8, DELETE"); ($s) = keys %{{pie => 3}}; SKIP: { - if (!eval { require B }) { skip "no B", 1 } + if (!eval { require B }) { skip "no B", 2 } my $wasro = B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY; - $wasro or local $TODO = "didn't have a COW"; + ok $wasro, "have a COW"; $s =~ tr/i//; ok( B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY, "count-only tr doesn't deCOW COWs" ); -- Perl5 Master Repository
