lvalue substr keeping lexical alive #9800
Comments
From user42@zip.com.auThe program foo.pl below prints SCALAR(0x874b2c0) where I hoped it would print undef, ie. the lexical scalar $str would be Some digging around suggests the scratchpad array in foo() holds a If a feature or unavoidable then take this report as a wish for For what it's worth I struck this in DBI.pm where it does a substr Flags: Site configuration information for perl 5.10.0: Configured by Debian Project at Thu Jul 9 09:30:18 UTC 2009. Summary of my perl5 (revision 5 version 10 subversion 0) configuration: |
From user42@zip.com.au |
From p5p@spam.wizbit.beOn Thu Jul 23 17:19:15 2009, kryde wrote:
lvalue substr seems to leak... Test case: #!/usr/bin/perl -l use strict; my $str = 'Hello World'; substr($str,0,1) = 'x'; substr($str,0,1) = 'x'; for (3, 4) { __END__ before: 1 (perl-5.6.0 (tested with Devel::Peek), perl-5.8.0 and everything in I'm guessing this is due to: LvTYPE(TARG) = 'x'; in pp_substr. Looking at the blame log this seems to be added in: Title: "5.004_04m5t1: Fix dangling references in LVs", "Fix dangling Title: "Fix SvGMAGIC typo in change 904" p4raw-id: //depot/maint-5.004/perl@906 Unfortunally no tests are added in that change :( This change also indicates that the same happens for vec() and pos(): #!/usr/bin/perl -l use strict; my $str = 'Hello World'; vec($str,0,1) = 0; vec($str,0,1) = 0; for (3, 4) { before: 1 #!/usr/bin/perl -l use strict; my $str = 'Hello World'; pos($str) = 0; pos($str) = 0; for (3, 4) { Anyone remembers the reason why this is/was nessesary? Best regards, Bram |
|
The RT System itself - Status changed from 'new' to 'open' |
From @ikegamiCreated by @ikegamivec increases the refcount of its target:
The memory leaking effects can be seen using these snippets:
This has been occurring at least as far back as 5.6.0 - Eric Perl Info |
From perl@profvince.comIt's not only lvalue vec(), it's also lvalue pos(), substr() and maybe I'll have a look at this. Vincent. |
|
The RT System itself - Status changed from 'new' to 'open' |
From perl@profvince.com
Actually, this has already been reported in |
|
bitcard@profvince.com - Status changed from 'open' to 'rejected' |
From @ikegamiOn Fri Jul 24 03:10:16 2009, animator wrote:
Yes ---BEGIN CODE--- for ($str, "a") { pos = 0; pos = 0; print "\n"; ---BEGIN ANNOTATED OUTPUT--- 3 What if we avoided using TARG when a lvalue is needed? I'll produce a |
From @ikegamiOn Thu Nov 05 12:56:29 2009, perl@profvince.com wrote:
Confirmed for all four. A patch to add tests is attached. A patch to fix the problem will follow shortly. |
From @ikegami0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patchFrom 78180596da61dd9a1bf6bfad643c10e67a89cdeb Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Fri, 6 Nov 2009 16:21:15 -0800
Subject: [PATCH] Tests to detect mem leaks in lvalue ops RT#67838
---
t/op/hash.t | 8 +++++++-
t/op/index.t | 8 +++++++-
t/op/pos.t | 6 +++++-
t/op/vec.t | 6 +++++-
4 files changed, 24 insertions(+), 4 deletions(-)
diff --git a/t/op/hash.t b/t/op/hash.t
index 9bde518..f507dd6 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -8,7 +8,7 @@ BEGIN {
use strict;
-plan tests => 6;
+plan tests => 8;
my %h;
@@ -118,3 +118,9 @@ my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
+
+{ # [RT#67838]
+ my %h = 'a'..'d';
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+}
diff --git a/t/op/index.t b/t/op/index.t
index 6cc3f42..24dca39 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -7,7 +7,7 @@ BEGIN {
}
use strict;
-plan( tests => 111 );
+plan( tests => 113 );
run_tests() unless caller;
@@ -200,3 +200,9 @@ SKIP: {
}
}
+
+{ # [RT#67838]
+ my $foo = "Hello, World!";
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+}
diff --git a/t/op/pos.t b/t/op/pos.t
index c3abfbe..eace6b1 100644
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan tests => 6;
+plan tests => 8;
$x='banana';
$x=~/.a/g;
@@ -28,3 +28,7 @@ $x = "123 56"; $x =~ / /g;
is(pos($x), 4);
{ local $x }
is(pos($x), 4);
+
+# [RT#67838]
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
diff --git a/t/op/vec.t b/t/op/vec.t
index aed1d0f..e217329 100644
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -6,7 +6,7 @@ BEGIN {
}
require "test.pl";
-plan( tests => 31 );
+plan( tests => 33 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
@@ -95,3 +95,7 @@ is($foo, "\x61\x62\x63\x34\x65\x66");
$r[$_] = \ vec $s, $_, 1 for (0, 1);
ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
}
+
+# [RT#67838]
+vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
--
1.5.6.5
|
From @ikegamiOn Fri Nov 06 16:25:33 2009, ikegami@adaelis.com wrote:
Two patches are attached. The first adds tests. It's an updated version of my earlier patch. It The second plugs the leaks by not using TARG when a lvalue is required. |
From @ikegami0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patchFrom b5752b4a862c33361c4df10856b3dd5f936886c7 Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Fri, 6 Nov 2009 17:40:41 -0800
Subject: [PATCH] Tests to detect mem leaks in lvalue ops RT#67838
---
t/op/hash.t | 8 +++++++-
t/op/index.t | 8 +++++++-
t/op/pos.t | 6 +++++-
t/op/vec.t | 8 +++++++-
4 files changed, 26 insertions(+), 4 deletions(-)
diff --git a/t/op/hash.t b/t/op/hash.t
index 9bde518..f507dd6 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -8,7 +8,7 @@ BEGIN {
use strict;
-plan tests => 6;
+plan tests => 8;
my %h;
@@ -118,3 +118,9 @@ my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
+
+{ # [RT#67838]
+ my %h = 'a'..'d';
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+}
diff --git a/t/op/index.t b/t/op/index.t
index 6cc3f42..24dca39 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -7,7 +7,7 @@ BEGIN {
}
use strict;
-plan( tests => 111 );
+plan( tests => 113 );
run_tests() unless caller;
@@ -200,3 +200,9 @@ SKIP: {
}
}
+
+{ # [RT#67838]
+ my $foo = "Hello, World!";
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+}
diff --git a/t/op/pos.t b/t/op/pos.t
index c3abfbe..eace6b1 100644
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan tests => 6;
+plan tests => 8;
$x='banana';
$x=~/.a/g;
@@ -28,3 +28,7 @@ $x = "123 56"; $x =~ / /g;
is(pos($x), 4);
{ local $x }
is(pos($x), 4);
+
+# [RT#67838]
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
diff --git a/t/op/vec.t b/t/op/vec.t
index aed1d0f..fe8a981 100644
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -6,7 +6,7 @@ BEGIN {
}
require "test.pl";
-plan( tests => 31 );
+plan( tests => 33 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
@@ -95,3 +95,9 @@ is($foo, "\x61\x62\x63\x34\x65\x66");
$r[$_] = \ vec $s, $_, 1 for (0, 1);
ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
}
+
+{ # [RT#67838]
+ my $foo = '';
+ vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+ vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+}
--
1.5.6.5
|
From @ikegami0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patchFrom a9bc77a75d1c3c12ca59c2ef26c4382507775aa3 Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Fri, 6 Nov 2009 17:45:19 -0800
Subject: [PATCH] Fix mem leaks in lvalue ops RT#67838
---
doop.c | 15 +++------
pp.c | 103 ++++++++++++++++++++++++++++++----------------------------------
2 files changed, 53 insertions(+), 65 deletions(-)
diff --git a/doop.c b/doop.c
index 3a5967d..b966c23 100644
--- a/doop.c
+++ b/doop.c
@@ -1461,16 +1461,11 @@ Perl_do_kv(pTHX)
dTARGET;
if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
- }
- LvTYPE(TARG) = 'k';
- if (LvTARG(TARG) != (const SV *)keys) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(keys);
- }
- PUSHs(TARG);
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0);
+ LvTYPE(ret) = 'k';
+ LvTARG(ret) = SvREFCNT_inc_simple(keys);
+ PUSHs(ret);
RETURN;
}
diff --git a/pp.c b/pp.c
index bb0e57d..7f1093f 100644
--- a/pp.c
+++ b/pp.c
@@ -342,17 +342,11 @@ PP(pp_pos)
dVAR; dSP; dTARGET; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
- }
-
- LvTYPE(TARG) = '.';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- PUSHs(TARG); /* no SvSETMAGIC */
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
+ LvTYPE(ret) = '.';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ PUSHs(ret); /* no SvSETMAGIC */
RETURN;
}
else {
@@ -3090,8 +3084,6 @@ PP(pp_substr)
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
if (num_args > 2) {
if (num_args > 3) {
repl_sv = POPs;
@@ -3167,6 +3159,39 @@ PP(pp_substr)
if (utf8_curlen)
sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
+
+ if (lvalue && !repl) {
+ SV * ret;
+
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force_nolen(sv);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr");
+ }
+ if (isGV_with_GP(sv))
+ SvPV_force_nolen(sv);
+ else if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only_UTF8(sv);
+ else
+ sv_setpvs(sv, ""); /* avoid lexical reincarnation */
+ }
+
+ ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(ret) = 'x';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(ret) = upos;
+ LvTARGLEN(ret) = urem;
+
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
+ }
+
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+
/* we either return a PV or an LV. If the TARG hasn't been used
* before, or is of that type, reuse it; otherwise use a mortal
* instead. Note that LVs can have an extended lifetime, so also
@@ -3186,6 +3211,7 @@ PP(pp_substr)
#endif
if (utf8_curlen)
SvUTF8_on(TARG);
+
if (repl) {
SV* repl_sv_copy = NULL;
@@ -3203,34 +3229,6 @@ PP(pp_substr)
if (repl_sv_copy)
SvREFCNT_dec(repl_sv_copy);
}
- else if (lvalue) { /* it's an lvalue! */
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
-
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
- }
-
- LvTYPE(TARG) = 'x';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- LvTARGOFF(TARG) = upos;
- LvTARGLEN(TARG) = urem;
- }
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
@@ -3245,23 +3243,18 @@ PP(pp_vec)
register SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
- SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
- if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
- TARG = sv_newmortal();
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
- }
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(src);
- }
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
+ LvTYPE(ret) = 'v';
+ LvTARG(ret) = SvREFCNT_inc_simple(src);
+ LvTARGOFF(ret) = offset;
+ LvTARGLEN(ret) = size;
+ PUSHs(ret);
+ RETURN;
}
+ SvTAINTED_off(TARG); /* decontaminate */
sv_setuv(TARG, do_vecget(src, offset, size));
PUSHs(TARG);
RETURN;
--
1.5.6.5
|
From @demerphq2009/11/7 Eric Brine via RT <perlbug-followup@perl.org>:
Just out of curiosity why does that code decontaminate differently in Yves -- |
From @ikegamiOn Sat, Nov 7, 2009 at 6:13 PM, yves orton via RT <perlbug-followup@perl.org
Some opcodes always return the result in the same SV to avoid having to The problem with these ops is { The mem will relacaimed the next time that substr instance is called. The patch has the ops use a fresh SV instead of TARG when they're used as Now to answer your question. Before TARG is reused by the op, it's untainted. There's no use untaintaing ELB |
From @ikegami[ Oops, my previous message didn't answer your question. I had misread it. On Sat, Nov 7, 2009 at 6:12 PM, demerphq <demerphq@gmail.com> wrote:
Only one of the four ops plays with the UTF8 flag because three of the ops - ELB |
From @rgarcia2009/11/7 Eric Brine via RT <perlbug-followup@perl.org>:
WIth this patch, the following tests fail : with the error "Can't return a temporary from lvalue subroutine". Also, the warnings.t failure apparently is a bug fix rather than a true failure. |
From perl@profvince.com
I'm not too sure about this. I'd rather : Vincent. |
From @ikegamiOn Sun, Nov 8, 2009 at 8:49 AM, Vincent Pit <perl@profvince.com> wrote:
Can't: $x = \substr(...); $x = \substr(...); What about a weak reference. Is that possible? I haven't looked at how those |
From @hvdsRafael Garcia-Suarez <rgs@consttype.org> wrote: Is it possible to restrict the leak only to the lvalue-sub case? (In fact, I feel it should be possible to have the best of both worlds. Hugo |
From @ikegamiOn Sun, Nov 8, 2009 at 12:21 PM, Hugo van der Sanden via RT <
As I understand it, yes. That's the "LVRET" in "PL_op->op_flags & OPf_MOD Considering the leak will probably never matter, another option would be to |
From @ikegamiOn Thu, Jul 23, 2009 at 7:19 PM, Kevin Ryde <perlbug-followup@perl.org>wrote:
What's the impact of the bug? substr, pos and vec operate on strings. Delaying the freeing of strings has keys operate on hashes. Delaying the freeing of a hash could have a What's the impact of the fix? Small slowdown due to the creation of a new SV for every lvalue call to Our options at this time: - Apply the provided patch, even though it will cause returning |
From user42@zip.com.au"Eric Brine via RT" <perlbug-followup@perl.org> writes:
Is that a question for me? As I said I didn't know if it was a bug, a
If it's a big string it would use up memory for a lot longer than you'd If the scalar is tied or has other magic it could be bad to delay its
I wouldn't mind knowing a way to identify scalars held alive like this, |
From user42@zip.com.au |
From user42@zip.com.au |
From @ikegamiOn Mon, Nov 16, 2009 at 4:03 PM, Kevin Ryde <user42@zip.com.au> wrote:
It was rhetorical. The answer followed.
Yes, but Perl already does that all over the place intentionally. For If the scalar is tied or has other magic it could be bad to delay its
I must have been tired, but I forgot magic had destructors. I may have
Since TARG variables are stored in the pad, you could go through the pad |
From @davidnicolOn Tue, Nov 17, 2009 at 12:45 PM, Eric Brine <ikegami@adaelis.com> wrote:
1: are there situations where a RAIL object will be the subject of one of 2: can TARG be a weak reference using current weak reference technology? -- |
From @ikegamiOn Tue, Nov 17, 2009 at 2:27 PM, David Nicol <davidnicol@gmail.com> wrote:
Yes. I previously gave the following example which demonstrates resources being # Timely release
# Resource held until global destruction
Here's an example that uses lvalue keys(%h) in the most straightforward perl -le' 2: can TARG be a weak reference using current weak reference technology? That was mentioned earlier in this thread, and seems from a high and distant
Yes, I believe so. What's wrong with that suggestion? The only downside is overhead. It makes yet another variable magical (the Should I only use weaken when necessary (lvalue subs)? When does TARG hold the last reference to something, See the reply to your first question. can TARG manipulation stuff simply leave reference counts alone? If these ops couldn't be used as the return value for lvalue subs, I believe Eric |
From @ikegamiOn Tue, Nov 17, 2009 at 6:22 PM, Eric Brine <ikegami@adaelis.com> wrote:
No, I was wrong. Conditions that must be met: - A magical var (e.g. PVLV) must be returned. If the TARG is a PLVL that targets an RV that weekly references the arg var, my $r; { my $s = ""; $r = \substr( If the TARG is an RV that weekly references a PVLV that references the arg sub :lvalue { my $s = ""; substr($s, 0, 1) }->(); |
From @ikegamiOn Wed, Nov 18, 2009 at 1:01 PM, Eric Brine <ikegami@adaelis.com> wrote:
It simply appears to be the case that the original coder forgot that TEMPs In fact, the sub was previously patched to allow a TEMP to be returned from use Tie::Array; Therefore, the solution is to extend the aforementioned exception to SVs Attached is the test patch (unchanged) and an updated fix patch the - Eric |
From @ikegami0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patchFrom feb04516ffd63b6754b734e167e97059107a0b85 Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Fri, 6 Nov 2009 17:40:41 -0800
Subject: [PATCH 1/2] Tests to detect mem leaks in lvalue ops RT#67838
---
t/op/hash.t | 8 +++++++-
t/op/index.t | 8 +++++++-
t/op/pos.t | 6 +++++-
t/op/vec.t | 8 +++++++-
4 files changed, 26 insertions(+), 4 deletions(-)
diff --git a/t/op/hash.t b/t/op/hash.t
index 9bde518..f507dd6 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -8,7 +8,7 @@ BEGIN {
use strict;
-plan tests => 6;
+plan tests => 8;
my %h;
@@ -118,3 +118,9 @@ my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
+
+{ # [RT#67838]
+ my %h = 'a'..'d';
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+ keys(%h)=0; is(Internals::SvREFCNT(%h), 1, 'Mem leak');
+}
diff --git a/t/op/index.t b/t/op/index.t
index 6cc3f42..24dca39 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -7,7 +7,7 @@ BEGIN {
}
use strict;
-plan( tests => 111 );
+plan( tests => 113 );
run_tests() unless caller;
@@ -200,3 +200,9 @@ SKIP: {
}
}
+
+{ # [RT#67838]
+ my $foo = "Hello, World!";
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+ substr($foo,0,1)='!'; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+}
diff --git a/t/op/pos.t b/t/op/pos.t
index c3abfbe..eace6b1 100644
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan tests => 6;
+plan tests => 8;
$x='banana';
$x=~/.a/g;
@@ -28,3 +28,7 @@ $x = "123 56"; $x =~ / /g;
is(pos($x), 4);
{ local $x }
is(pos($x), 4);
+
+# [RT#67838]
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
+pos($x) = 0; is(Internals::SvREFCNT($x), 1, 'Mem leak');
diff --git a/t/op/vec.t b/t/op/vec.t
index aed1d0f..fe8a981 100644
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -6,7 +6,7 @@ BEGIN {
}
require "test.pl";
-plan( tests => 31 );
+plan( tests => 33 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
@@ -95,3 +95,9 @@ is($foo, "\x61\x62\x63\x34\x65\x66");
$r[$_] = \ vec $s, $_, 1 for (0, 1);
ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
}
+
+{ # [RT#67838]
+ my $foo = '';
+ vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+ vec($foo,0,1)=0; is(Internals::SvREFCNT($foo), 1, 'Mem leak');
+}
--
1.6.5.2
|
From @ikegami0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patchFrom 45c6e6e3c52dc1824ecdc4edb329b373204bc0da Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Sun, 22 Nov 2009 15:46:30 -0800
Subject: [PATCH 2/2] Fix mem leaks in lvalue ops RT#67838
---
doop.c | 15 +++------
pp.c | 109 +++++++++++++++++++++++++++++--------------------------------
pp_hot.c | 2 +-
3 files changed, 58 insertions(+), 68 deletions(-)
diff --git a/doop.c b/doop.c
index c43ecb1..fd444f1 100644
--- a/doop.c
+++ b/doop.c
@@ -1460,16 +1460,11 @@ Perl_do_kv(pTHX)
dTARGET;
if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
- }
- LvTYPE(TARG) = 'k';
- if (LvTARG(TARG) != (const SV *)keys) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(keys);
- }
- PUSHs(TARG);
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0);
+ LvTYPE(ret) = 'k';
+ LvTARG(ret) = SvREFCNT_inc_simple(keys);
+ PUSHs(ret);
RETURN;
}
diff --git a/pp.c b/pp.c
index b271e7b..88cdb42 100644
--- a/pp.c
+++ b/pp.c
@@ -345,17 +345,11 @@ PP(pp_pos)
dVAR; dSP; dTARGET; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
- }
-
- LvTYPE(TARG) = '.';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- PUSHs(TARG); /* no SvSETMAGIC */
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
+ LvTYPE(ret) = '.';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ PUSHs(ret); /* no SvSETMAGIC */
RETURN;
}
else {
@@ -3093,8 +3087,6 @@ PP(pp_substr)
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
if (num_args > 2) {
if (num_args > 3) {
repl_sv = POPs;
@@ -3170,6 +3162,39 @@ PP(pp_substr)
if (utf8_curlen)
sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
+
+ if (lvalue && !repl) {
+ SV * ret;
+
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force_nolen(sv);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr");
+ }
+ if (isGV_with_GP(sv))
+ SvPV_force_nolen(sv);
+ else if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only_UTF8(sv);
+ else
+ sv_setpvs(sv, ""); /* avoid lexical reincarnation */
+ }
+
+ ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(ret) = 'x';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(ret) = upos;
+ LvTARGLEN(ret) = urem;
+
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
+ }
+
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+
/* we either return a PV or an LV. If the TARG hasn't been used
* before, or is of that type, reuse it; otherwise use a mortal
* instead. Note that LVs can have an extended lifetime, so also
@@ -3189,6 +3214,7 @@ PP(pp_substr)
#endif
if (utf8_curlen)
SvUTF8_on(TARG);
+
if (repl) {
SV* repl_sv_copy = NULL;
@@ -3205,34 +3231,6 @@ PP(pp_substr)
SvUTF8_on(sv);
SvREFCNT_dec(repl_sv_copy);
}
- else if (lvalue) { /* it's an lvalue! */
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
-
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
- }
-
- LvTYPE(TARG) = 'x';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- LvTARGOFF(TARG) = upos;
- LvTARGLEN(TARG) = urem;
- }
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
@@ -3246,26 +3244,23 @@ PP(pp_vec)
register const IV offset = POPi;
register SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ SV * ret;
- SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
- if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
- TARG = sv_newmortal();
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
- }
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(src);
- }
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ ret = sv_2mortal(newSV_type(SVt_PVLV));
+ sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
+ LvTYPE(ret) = 'v';
+ LvTARG(ret) = SvREFCNT_inc_simple(src);
+ LvTARGOFF(ret) = offset;
+ LvTARGLEN(ret) = size;
+ }
+ else {
+ SvTAINTED_off(TARG); /* decontaminate */
+ ret = TARG;
}
- sv_setuv(TARG, do_vecget(src, offset, size));
- PUSHs(TARG);
+ sv_setuv(ret, do_vecget(src, offset, size));
+ PUSHs(ret);
RETURN;
}
diff --git a/pp_hot.c b/pp_hot.c
index 48b57d6..2612f6b 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2549,7 +2549,7 @@ PP(pp_leavesublv)
/* Temporaries are bad unless they happen to be elements
* of a tied hash or array */
if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
- !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+ !SvSMAGICAL(TOPs)) {
LEAVE_with_name("sub");
cxstack_ix--;
POPSUB(cx,sv);
--
1.6.5.2
|
From user42@zip.com.au"Eric Brine via RT" <perlbug-followup@perl.org> writes:
Ah, I didn't know that. Makes it hard to work carefully with big |
From @TuxOn Fri, 27 Nov 2009 11:41:19 +1100, Kevin Ryde <user42@zip.com.au>
$s = undef; especially safe when $s is an object (e.g. a DBI statement handle) that -- |
From Eirik-Berg.Hanssen@allverden.no"H.Merijn Brand" <h.m.brand@xs4all.nl> writes:
Did you mean undef($s), or did something change while I was not Eirik, who doesn't use that feature often either |
From @TuxOn Fri, 27 Nov 2009 15:38:03 +0100, Eirik Berg Hanssen
Both is allowed, but indeed only 'undef ($x)' frees the variable. I was $ perl -MDP -wle'$_="x"x10;DDump$_;$_=undef;DDump$_' SV = PV(0x743158) at 0x782198 $ perl -MDP -wle'$_="x"x10;DDump$_;undef$_;DDump$_' SV = PV(0x743158) at 0x782198 $
-- |
From @TuxOn Sun, 29 Nov 2009 00:51:49 +0100, Eirik Berg Hanssen
If '$s = undef' is clearly not doing what might be expected, is there How easy would it be to `optimize' that in perl itself?
-- |
From user42@zip.com.au"H.Merijn Brand" <h.m.brand@xs4all.nl> writes:
Umm, sounds a bit like hard work if you have to catch all variables that |
From @ikegamiOn Sun, Nov 29, 2009 at 5:11 AM, H.Merijn Brand <h.m.brand@xs4all.nl> wrote:
No, I don't see how it could.
You mean remove the optimisation to prevent unnecessary calls to malloc. The answer might depend on exactly what you want. Do you wish to free the 1) When the result of a call to undef is assigned to it? I'm not sure it's wise to remove this optimisation for the rare occurrence ELB |
From @davidnicolOn Mon, Nov 30, 2009 at 2:34 PM, Eric Brine <ikegami@adaelis.com> wrote:
how about "when there's memory pressure?" |
From @TuxOn Mon, 30 Nov 2009 15:34:08 -0500, Eric Brine <ikegami@adaelis.com>
I'm not pushing anymore, but /I/ don't see *any* use here. If I want to
Yes to all four points, but I'll change my habits.
I was looking from the other side. I used $s = undef *expecting* it to And jdb, I'm not propagating people to undef all their values -- |
From @ikegamiOn Mon, Nov 30, 2009 at 3:58 PM, H.Merijn Brand <h.m.brand@xs4all.nl> wrote:
The empty string is not the same thing as undef. You can't assign the empty
Variables going out of scope are not freed (if there are no external $ perl -MDevel::Peek -e'sub f { my $x; Dump $x; $x=$_[0]; Dump $x; } f but I have seen places where using undef $sth would force a DESTROY that otherwise would have been too late. $sth=undef; and even $sth=123; would have worked just as well. Aside from - ELB |
From @davidnicolperldoc -f undef could use a sentence discussing freeing large string 10. $buf = undef; # defined($buf) is now false, but $buf's memory |
From @iabynEric notes that he has pending work on this ticket |
From @ikegamiHi, Attached are updated versions of patches submitted during the 5.12 - Eric Brine |
From @ikegami0001-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patchFrom aabd9b21db75e6b3dd918ffa3d11fcfa5f66368f Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Tue, 13 Jul 2010 12:36:55 -0700
Subject: [PATCH 1/4] Pure Perl lvalue subs can't return temps, even if they are magical.
This holds back a fix for RT#67838.
Adds TODO tests.
---
MANIFEST | 1 +
ext/XS-APItest/APItest.pm | 2 +-
ext/XS-APItest/APItest.xs | 37 +++++++++++++++++++++++++++++++++++++
ext/XS-APItest/t/temp_lv_sub.t | 37 +++++++++++++++++++++++++++++++++++++
4 files changed, 76 insertions(+), 1 deletions(-)
create mode 100644 ext/XS-APItest/t/temp_lv_sub.t
diff --git a/MANIFEST b/MANIFEST
index 111d4f2..b2273a5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3269,6 +3269,7 @@ ext/XS-APItest/t/push.t XS::APItest extension
ext/XS-APItest/t/rmagical.t XS::APItest extension
ext/XS-APItest/t/svpeek.t XS::APItest extension
ext/XS-APItest/t/svsetsv.t Test behaviour of sv_setsv with/without PERL_CORE
+ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps
ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed}
ext/XS-APItest/t/xs_special_subs_require.t for require too
ext/XS-APItest/t/xs_special_subs.t Test that XS BEGIN/CHECK/INIT/END work
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 73db4a5..05546ff 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -27,7 +27,7 @@ our @EXPORT = qw( print_double print_int print_long
sv_count
);
-our $VERSION = '0.19';
+our $VERSION = '0.20';
use vars '$WARNINGS_ON_BOOTSTRAP';
use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 9e5ebe8..8dce9db 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -653,6 +653,29 @@ sub CLEAR { %{$_[0]} = () }
=cut
+
+MODULE = XS::APItest:TempLv PACKAGE = XS::APItest::TempLv
+
+void
+make_temp_mg_lv(sv)
+SV* sv
+ PREINIT:
+ SV * const lv = newSV_type(SVt_PVLV);
+ STRLEN len;
+ PPCODE:
+ SvPV(sv, len);
+
+ sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(lv) = 'x';
+ LvTARG(lv) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(lv) = len == 0 ? 0 : 1;
+ LvTARGLEN(lv) = len < 2 ? 0 : len-2;
+
+ EXTEND(SP, 1);
+ ST(0) = sv_2mortal(lv);
+ XSRETURN(1);
+
+
MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
void
@@ -1137,3 +1160,17 @@ peep_record_clear ()
dMY_CXT;
CODE:
av_clear(MY_CXT.peep_record);
+
+BOOT:
+ {
+ HV* stash;
+ SV** meth = NULL;
+ CV* cv;
+ stash = gv_stashpv("XS::APItest::TempLv", 0);
+ if (stash)
+ meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
+ if (!meth)
+ croak("lost method 'make_temp_mg_lv'");
+ cv = GvCV(*meth);
+ CvLVALUE_on(cv);
+ }
diff --git a/ext/XS-APItest/t/temp_lv_sub.t b/ext/XS-APItest/t/temp_lv_sub.t
new file mode 100644
index 0000000..bfcacd6
--- /dev/null
+++ b/ext/XS-APItest/t/temp_lv_sub.t
@@ -0,0 +1,37 @@
+#!perl -w
+
+BEGIN {
+ push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+ # Look, I'm using this fully-qualified variable more than once!
+ my $arch = $MacPerl::Architecture;
+ print "1..0 # Skip: XS::APItest was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use utf8;
+use Test::More tests => 5;
+
+BEGIN {use_ok('XS::APItest')};
+
+sub make_temp_mg_lv :lvalue { XS::APItest::TempLv::make_temp_mg_lv($_[0]); }
+
+{
+ my $x = "[]";
+ eval { XS::APItest::TempLv::make_temp_mg_lv($x) = "a"; };
+ is($@, '', 'temp mg lv from xs exception check');
+ is($x, '[a]', 'temp mg lv from xs success');
+}
+
+{
+ local $TODO = "PP lvalue sub can't return magical temp";
+ my $x = "{}";
+ eval { make_temp_mg_lv($x) = "b"; };
+ is($@, '', 'temp mg lv from pp exception check');
+ is($x, '{b}', 'temp mg lv from pp success');
+}
+
+1;
--
1.7.1.1
|
From @ikegami0002-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patchFrom bca7bab5acc5a0c7614cc747b641c9b7a58a143d Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Tue, 13 Jul 2010 12:56:38 -0700
Subject: [PATCH 2/4] Pure Perl lvalue subs can't return temps, even if they are magical.
This holds back a fix for RT#67838.
This commit allows PP lvalue subs to return temps with set magic
and removes TODO from tests.
---
ext/XS-APItest/t/temp_lv_sub.t | 1 -
pp_hot.c | 6 +++---
2 files changed, 3 insertions(+), 4 deletions(-)
diff --git a/ext/XS-APItest/t/temp_lv_sub.t b/ext/XS-APItest/t/temp_lv_sub.t
index bfcacd6..d0c51fd 100644
--- a/ext/XS-APItest/t/temp_lv_sub.t
+++ b/ext/XS-APItest/t/temp_lv_sub.t
@@ -27,7 +27,6 @@ sub make_temp_mg_lv :lvalue { XS::APItest::TempLv::make_temp_mg_lv($_[0]); }
}
{
- local $TODO = "PP lvalue sub can't return magical temp";
my $x = "{}";
eval { make_temp_mg_lv($x) = "b"; };
is($@, '', 'temp mg lv from pp exception check');
diff --git a/pp_hot.c b/pp_hot.c
index d66ddde..31a3ee8 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2609,13 +2609,13 @@ PP(pp_leavesublv)
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- /* Temporaries are bad unless they happen to be elements
- * of a tied hash or array */
+ /* Temporaries are bad unless they happen to have set magic
+ * attached, such as the elements of a tied hash or array */
if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
(SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
== SVf_READONLY
) &&
- !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+ !SvSMAGICAL(TOPs)) {
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
--
1.7.1.1
|
From @ikegami0003-TODO-tests-for-untimely-destruction-introduced-by-lv.patchFrom 2f670359e544907567eff1a3ee16ac8a76e90d98 Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Fri, 30 Jul 2010 09:43:29 -0700
Subject: [PATCH 3/4] TODO tests for untimely destruction introduced by lvalue ops [RT#67838]
---
t/op/hash.t | 17 ++++++++++++++++-
t/op/pos.t | 16 +++++++++++++++-
t/op/vec.t | 17 ++++++++++++++++-
t/re/substr.t | 17 ++++++++++++++++-
4 files changed, 63 insertions(+), 4 deletions(-)
diff --git a/t/op/hash.t b/t/op/hash.t
index 9bde518..999ffc0 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -8,7 +8,7 @@ BEGIN {
use strict;
-plan tests => 6;
+plan tests => 7;
my %h;
@@ -118,3 +118,18 @@ my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
+
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+ my %h;
+ keys(%h) = 1;
+ $h{key} = bless({}, 'Class');
+}
+{
+ local our $TODO = "RT#67838";
+ is($destroyed, 1, 'Timely hash destruction with lvalue keys');
+}
diff --git a/t/op/pos.t b/t/op/pos.t
index 04263e1..2d60417 100644
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan tests => 7;
+plan tests => 8;
$x='banana';
$x=~/.a/g;
@@ -36,3 +36,17 @@ $x = "\x{100}BC";
$x =~ m/.*/g;
is(pos $x, 3);
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+ my $x = '';
+ pos($x) = 0;
+ $x = bless({}, 'Class');
+}
+{
+ local $TODO = "RT#67838";
+ is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
+}
diff --git a/t/op/vec.t b/t/op/vec.t
index aed1d0f..7fb3019 100644
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -6,7 +6,7 @@ BEGIN {
}
require "test.pl";
-plan( tests => 31 );
+plan( tests => 32 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
@@ -95,3 +95,18 @@ is($foo, "\x61\x62\x63\x34\x65\x66");
$r[$_] = \ vec $s, $_, 1 for (0, 1);
ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
}
+
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+ my $x = '';
+ vec($x,0,1) = 0;
+ $x = bless({}, 'Class');
+}
+{
+ local $TODO = "RT#67838";
+ is($destroyed, 1, 'Timely scalar destruction with lvalue vec');
+}
diff --git a/t/re/substr.t b/t/re/substr.t
index d0717ba..b136502 100644
--- a/t/re/substr.t
+++ b/t/re/substr.t
@@ -24,7 +24,7 @@ $SIG{__WARN__} = sub {
require './test.pl';
-plan(360);
+plan(361);
run_tests() unless caller;
@@ -723,3 +723,18 @@ SKIP: {
}
}
+
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+ my $x = '';
+ substr($x,0,1) = "";
+ $x = bless({}, 'Class');
+}
+{
+ local $TODO = "RT#67838";
+ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
+}
--
1.7.1.1
|
From @ikegami0004-Fix-untimely-destruction-introduced-by-lvalue-ops-RT.patchFrom ccc36f4e94c1a8a70d1c701c2393930a104ff58c Mon Sep 17 00:00:00 2001
From: Eric Brine <ikegami@adaelis.com>
Date: Sat, 31 Jul 2010 01:56:43 -0700
Subject: [PATCH 4/4] Fix untimely destruction introduced by lvalue ops [RT#67838]
by returning a TEMP instead of using TARG.
Made appropriate TODO tests live.
---
doop.c | 38 +++++++----------
pp.c | 123 ++++++++++++++++++++++++--------------------------------
t/op/hash.t | 5 +--
t/op/pos.t | 5 +--
t/op/vec.t | 5 +--
t/re/substr.t | 5 +--
6 files changed, 73 insertions(+), 108 deletions(-)
diff --git a/doop.c b/doop.c
index c1a357c..903144c 100644
--- a/doop.c
+++ b/doop.c
@@ -1456,32 +1456,26 @@ Perl_do_kv(pTHX)
RETURN;
if (gimme == G_SCALAR) {
- IV i;
- dTARGET;
-
if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
- }
- LvTYPE(TARG) = 'k';
- if (LvTARG(TARG) != (const SV *)keys) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(keys);
- }
- PUSHs(TARG);
- RETURN;
- }
-
- if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) )
- {
- i = HvKEYS(keys);
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0);
+ LvTYPE(ret) = 'k';
+ LvTARG(ret) = SvREFCNT_inc_simple(keys);
+ PUSHs(ret);
}
else {
- i = 0;
- while (hv_iternext(keys)) i++;
+ IV i;
+ dTARGET;
+
+ if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) {
+ i = HvKEYS(keys);
+ }
+ else {
+ i = 0;
+ while (hv_iternext(keys)) i++;
+ }
+ PUSHi( i );
}
- PUSHi( i );
RETURN;
}
diff --git a/pp.c b/pp.c
index 129c948..8d7952b 100644
--- a/pp.c
+++ b/pp.c
@@ -336,26 +336,21 @@ PP(pp_av2arylen)
PP(pp_pos)
{
- dVAR; dSP; dTARGET; dPOPss;
+ dVAR; dSP; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
- }
-
- LvTYPE(TARG) = '.';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- PUSHs(TARG); /* no SvSETMAGIC */
+ SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
+ LvTYPE(ret) = '.';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ PUSHs(ret); /* no SvSETMAGIC */
RETURN;
}
else {
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
+ dTARGET;
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
@@ -3146,8 +3141,6 @@ PP(pp_substr)
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
if (num_args > 2) {
if (num_args > 3) {
repl_sv = POPs;
@@ -3255,26 +3248,46 @@ PP(pp_substr)
STRLEN byte_pos = utf8_curlen
? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
- tmps += byte_pos;
- /* we either return a PV or an LV. If the TARG hasn't been used
- * before, or is of that type, reuse it; otherwise use a mortal
- * instead. Note that LVs can have an extended lifetime, so also
- * dont reuse if refcount > 1 (bug #20933) */
- if (SvTYPE(TARG) > SVt_NULL) {
- if ( (SvTYPE(TARG) == SVt_PVLV)
- ? (!lvalue || SvREFCNT(TARG) > 1)
- : lvalue)
- {
- TARG = sv_newmortal();
+ if (lvalue && !repl) {
+ SV * ret;
+
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force_nolen(sv);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr");
+ }
+ if (isGV_with_GP(sv))
+ SvPV_force_nolen(sv);
+ else if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only_UTF8(sv);
+ else
+ sv_setpvs(sv, ""); /* avoid lexical reincarnation */
}
+
+ ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(ret) = 'x';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(ret) = pos;
+ LvTARGLEN(ret) = len;
+
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
}
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+
+ tmps += byte_pos;
sv_setpvn(TARG, tmps, byte_len);
#ifdef USE_LOCALE_COLLATE
sv_unmagic(TARG, PERL_MAGIC_collxfrm);
#endif
if (utf8_curlen)
SvUTF8_on(TARG);
+
if (repl) {
SV* repl_sv_copy = NULL;
@@ -3291,34 +3304,6 @@ PP(pp_substr)
SvUTF8_on(sv);
SvREFCNT_dec(repl_sv_copy);
}
- else if (lvalue) { /* it's an lvalue! */
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
-
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
- }
-
- LvTYPE(TARG) = 'x';
- if (LvTARG(TARG) != sv) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(sv);
- }
- LvTARGOFF(TARG) = pos;
- LvTARGLEN(TARG) = len;
- }
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
@@ -3333,31 +3318,29 @@ bound_fail:
PP(pp_vec)
{
- dVAR; dSP; dTARGET;
+ dVAR; dSP;
register const IV size = POPi;
register const IV offset = POPi;
register SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ SV * ret;
- SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
- if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
- TARG = sv_newmortal();
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
- }
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc_simple(src);
- }
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
+ LvTYPE(ret) = 'v';
+ LvTARG(ret) = SvREFCNT_inc_simple(src);
+ LvTARGOFF(ret) = offset;
+ LvTARGLEN(ret) = size;
+ }
+ else {
+ dTARGET;
+ SvTAINTED_off(TARG); /* decontaminate */
+ ret = TARG;
}
- sv_setuv(TARG, do_vecget(src, offset, size));
- PUSHs(TARG);
+ sv_setuv(ret, do_vecget(src, offset, size));
+ PUSHs(ret);
RETURN;
}
diff --git a/t/op/hash.t b/t/op/hash.t
index 999ffc0..d75d059 100644
--- a/t/op/hash.t
+++ b/t/op/hash.t
@@ -129,7 +129,4 @@ $destroyed = 0;
keys(%h) = 1;
$h{key} = bless({}, 'Class');
}
-{
- local our $TODO = "RT#67838";
- is($destroyed, 1, 'Timely hash destruction with lvalue keys');
-}
+is($destroyed, 1, 'Timely hash destruction with lvalue keys');
diff --git a/t/op/pos.t b/t/op/pos.t
index 2d60417..38fd034 100644
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -46,7 +46,4 @@ $destroyed = 0;
pos($x) = 0;
$x = bless({}, 'Class');
}
-{
- local $TODO = "RT#67838";
- is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
-}
+is($destroyed, 1, 'Timely scalar destruction with lvalue pos');
diff --git a/t/op/vec.t b/t/op/vec.t
index 7fb3019..9e69c22 100644
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -106,7 +106,4 @@ $destroyed = 0;
vec($x,0,1) = 0;
$x = bless({}, 'Class');
}
-{
- local $TODO = "RT#67838";
- is($destroyed, 1, 'Timely scalar destruction with lvalue vec');
-}
+is($destroyed, 1, 'Timely scalar destruction with lvalue vec');
diff --git a/t/re/substr.t b/t/re/substr.t
index b136502..4f34b26 100644
--- a/t/re/substr.t
+++ b/t/re/substr.t
@@ -734,7 +734,4 @@ $destroyed = 0;
substr($x,0,1) = "";
$x = bless({}, 'Class');
}
-{
- local $TODO = "RT#67838";
- is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
-}
+is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
--
1.7.1.1
|
From @rgarciaOn 31 July 2010 21:27, Eric Brine <ikegami@adaelis.com> wrote:
Thanks, applied to bleadperl. |
|
@rgs - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#67838 (status was 'resolved')
Searchable as RT67838$
The text was updated successfully, but these errors were encountered: