lvalue substr keeping lexical alive

[p5pRT]

Migrated from rt.perl.org#67838 (status was 'resolved')

Searchable as RT67838$

[p5pRT]

From user42@zip.com.au

The program foo.pl below prints

  SCALAR(0x874b2c0)

where I hoped it would print undef\, ie. the lexical scalar $str would be garbage collected on going out of scope. undef is what I get without the lvalue substr() assignment\, or with a 4-arg substr call.

Some digging around suggests the scratchpad array in foo() holds a reference to the $str scalar if an lvalue substr is used this way. I don't know if that's a bug\, a feature\, or an unavoidable side-effect of the implementation.

If a feature or unavoidable then take this report as a wish for something in the docs on the subject\, as even perlguts seems very thin on anything about lvalue scalars.

For what it's worth I struck this in DBI.pm where it does a substr modify like this and the resulting scalar looks like a memory leak to Test​::Weaken. I think it really is a leak\, but only a temporary one since the next call to foo() or whatever function seems to clear it out. Of course if a string is very big it'd be bad to have it hanging around in core beyond what you normally expect to be its scope.

---

---

Flags​:   category=core   severity=medium

---

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​:   Platform​:   osname=linux\, osvers=2.6.30.1-dsa-ia32\, archname=i486-linux-gnu-thread-multi   uname='linux murphy 2.6.30.1-dsa-ia32 #1 smp fri jul 3 12​:55​:10 cest 2009 i686 gnulinux '   config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.10 -Darchlib=/usr/lib/perl/5.10 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.10.0 -Dsitearch=/usr/local/lib/perl/5.10.0 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio -Uusenm -DDEBUGGING=-g -Doptimize=-O2 -Duseshrplib -Dlibperl=libperl.so.5.10.0 -Dd_dosuid -des'   hint=recommended\, useposix=true\, d_sigaction=define   useithreads=define\, usemultiplicity=define   useperlio=define\, d_sfio=undef\, uselargefiles=define\, usesocks=undef   use64bitint=undef\, use64bitall=undef\, uselongdouble=undef   usemymalloc=n\, bincompat5005=undef   Compiler​:   cc='cc'\, ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'\,   optimize='-O2 -g'\,   cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include'   ccversion=''\, gccversion='4.3.3'\, gccosandvers=''   intsize=4\, longsize=4\, ptrsize=4\, doublesize=8\, byteorder=1234   d_longlong=define\, longlongsize=8\, d_longdbl=define\, longdblsize=12   ivtype='long'\, ivsize=4\, nvtype='double'\, nvsize=8\, Off_t='off_t'\, lseeksize=8   alignbytes=4\, prototype=define   Linker and Libraries​:   ld='cc'\, ldflags =' -L/usr/local/lib'   libpth=/usr/local/lib /lib /usr/lib /usr/lib64   libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt   perllibs=-ldl -lm -lpthread -lc -lcrypt   libc=/lib/libc-2.9.so\, so=so\, useshrplib=true\, libperl=libperl.so.5.10.0   gnulibc_version='2.9'   Dynamic Linking​:   dlsrc=dl_dlopen.xs\, dlext=so\, d_dlsymun=undef\, ccdlflags='-Wl\,-E'   cccdlflags='-fPIC'\, lddlflags='-shared -O2 -g -L/usr/local/lib'

[p5pRT]

From user42@zip.com.au

foo.pl

[p5pRT]

From p5p@spam.wizbit.be

On Thu Jul 23 17​:19​:15 2009\, kryde wrote​:

The program foo.pl below prints

SCALAR\(0x874b2c0\)

where I hoped it would print undef\, ie. the lexical scalar $str would be garbage collected on going out of scope. undef is what I get without the lvalue substr() assignment\, or with a 4-arg substr call.

Some digging around suggests the scratchpad array in foo() holds a reference to the $str scalar if an lvalue substr is used this way. I don't know if that's a bug\, a feature\, or an unavoidable side-effect of the implementation.

If a feature or unavoidable then take this report as a wish for something in the docs on the subject\, as even perlguts seems very thin on anything about lvalue scalars.

lvalue substr seems to leak...

Test case​:

#!/usr/bin/perl -l

use strict; use warnings;

my $str = 'Hello World'; print "before​: " . Internals​::SvREFCNT($str);

substr($str\,0\,1) = 'x'; print "after (1)​: " . Internals​::SvREFCNT($str);

substr($str\,0\,1) = 'x'; print "after (2)​: " . Internals​::SvREFCNT($str);

for (3\, 4) {   print "before ($_) (loop)​: " . Internals​::SvREFCNT($str);   substr($str\,0\,1) = 'x';   print "after ($_) (loop)​: " . Internals​::SvREFCNT($str); }

__END__ Output (with blead)​:

before​: 1 after (1)​: 2 after (2)​: 3 before (3) (loop)​: 3 after (3) (loop)​: 4 before (4) (loop)​: 4 after (4) (loop)​: 4

(perl-5.6.0 (tested with Devel​::Peek)\, perl-5.8.0 and everything in between behaves the same as blead)

I'm guessing this is due to​:

  LvTYPE(TARG) = 'x';   if (LvTARG(TARG) != sv) {   if (LvTARG(TARG))   SvREFCNT_dec(LvTARG(TARG));   LvTARG(TARG) = SvREFCNT_inc_simple(sv);   }

in pp_substr.

Looking at the blame log this seems to be added in​: http​://perl5.git.perl.org/perl.git/blobdiff/ 15e73149a8419f18d739227762eab108524cec56..ae389c8a29b487f4434c465442dfb611507a4a38​:/ pp.c [core language changes]

Title​: "5.004_04m5t1​: Fix dangling references in LVs"\, "Fix dangling   references in LVs" Msg-ID​: \199804010541\.AAA32615@​Orb\.Nashua\.NH\.US\,   \19980422164037\.D29222@​perl\.org Files​: embed.h keywords.h opcode.h perl.h proto.h doop.c global.sym mg.c   pp.c sv.c

Title​: "Fix SvGMAGIC typo in change 904" Files​: doop.c

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; use warnings;

my $str = 'Hello World'; print "before​: " . Internals​::SvREFCNT($str);

vec($str\,0\,1) = 0; print "after (1)​: " . Internals​::SvREFCNT($str);

vec($str\,0\,1) = 0; print "after (2)​: " . Internals​::SvREFCNT($str);

for (3\, 4) {   print "before ($_) (loop)​: " . Internals​::SvREFCNT($str);   vec($str\,0\,1) = 0;   print "after ($_) (loop)​: " . Internals​::SvREFCNT($str); } __END__

before​: 1 after (1)​: 2 after (2)​: 3 before (3) (loop)​: 3 after (3) (loop)​: 4 before (4) (loop)​: 4 after (4) (loop)​: 4

#!/usr/bin/perl -l

use strict; use warnings;

my $str = 'Hello World'; print "before​: " . Internals​::SvREFCNT($str);

pos($str) = 0;
print "after (1)​: " . Internals​::SvREFCNT($str);

pos($str) = 0;
print "after (2)​: " . Internals​::SvREFCNT($str);

for (3\, 4) {   print "before ($_) (loop)​: " . Internals​::SvREFCNT($str);   pos($str) = 0;
  print "after ($_) (loop)​: " . Internals​::SvREFCNT($str); } __END__ before​: 1 after (1)​: 2 after (2)​: 3 before (3) (loop)​: 3 after (3) (loop)​: 4 before (4) (loop)​: 4 after (4) (loop)​: 4

Anyone remembers the reason why this is/was nessesary? (I haven't tested yet what happens when the refcount isn't increased)

Best regards\,

Bram

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @ikegami

Created by @ikegami

vec increases the refcount of its target​:

perl -MDevel​::Peek -le"my $x=''; Dump $x; vec($x\,0\,1)=0; Dump $x;" SV = PV(0x236044) at 0x238264   REFCNT = 1   FLAGS = (PADMY\,POK\,pPOK)   PV = 0x23fd84 ""\0   CUR = 0   LEN = 4 SV = PV(0x236044) at 0x238264   REFCNT = 2   FLAGS = (PADMY\,POK\,pPOK)   PV = 0x23fd84 "\0"\0   CUR = 1   LEN = 4

The memory leaking effects can be seen using these snippets​:

perl -le"{ my $x=''; $x = bless {}; } print 'G'; DESTROY { print 'D' }" D G

perl -le"{ my $x=''; vec($x\,0\,1)=0; $x = bless {}; } print 'G'; DESTROY { print 'D' }" G D

This has been occurring at least as far back as 5.6.0

- Eric

Perl Info

``` Flags: category=core severity=medium Site configuration information for perl 5.10.1: Configured by SYSTEM at Mon Aug 24 13:48:02 2009. Summary of my perl5 (revision 5 version 10 subversion 1) configuration: Platform: osname=MSWin32, osvers=5.00, archname=MSWin32-x86-multi-thread uname='' config_args='undef' hint=recommended, useposix=true, d_sigaction=undef useithreads=define, usemultiplicity=define useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef use64bitint=undef, use64bitall=undef, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cl', ccflags ='-nologo -GF -W3 -MD -Zi -DNDEBUG -O1 -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT -DUSE_SITECUSTOMIZE -DPRIVLIB_LAST_IN_INC -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READFIX', optimize='-MD -Zi -DNDEBUG -O1', cppflags='-DWIN32' ccversion='12.00.8804', gccversion='', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=8 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='__int64', lseeksize=8 alignbytes=8, prototype=define Linker and Libraries: ld='link', ldflags ='-nologo -nodefaultlib -debug -opt:ref,icf -libpath:"C:\progs\perl5101\lib\CORE" -machine:x86' libpth=\lib libs= oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib perllibs= oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib msvcrt.lib libc=msvcrt.lib, so=dll, useshrplib=true, libperl=perl510.lib gnulibc_version='' Dynamic Linking: dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' ' cccdlflags=' ', lddlflags='-dll -nologo -nodefaultlib -debug -opt:ref,icf -libpath:"C:\progs\perl5101\lib\CORE" -machine:x86' Locally applied patches: ACTIVEPERL_LOCAL_PATCHES_ENTRY 32728 64-bit fix for Time::Local @INC for perl 5.10.1: c:/Progs/perl5101/site/lib c:/Progs/perl5101/lib . Environment for perl 5.10.1: HOME (unset) LANG (unset) LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH=c:\bin;c:\progs\perl5101\bin;C:\WINDOWS\system32;C:\WINDOWS;C:\WINDOWS\System32\WBEM PERL_BADLANG (unset) SHELL (unset) ```

[p5pRT]

From perl@profvince.com

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

I'll have a look at this.

Vincent.

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From perl@profvince.com

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

I'll have a look at this.

Vincent.

Actually\, this has already been reported in http​://rt.perl.org/rt3/Ticket/Display.html?id=67838\, and I came to the same conclusions as Bram. Let's continue there.

[p5pRT]

bitcard@profvince.com - Status changed from 'open' to 'rejected'

[p5pRT]

From @ikegami

On Fri Jul 24 03​:10​:16 2009\, animator wrote​:

I'm guessing this is due to​:

        LvTYPE\(TARG\) = 'x';
        if \(LvTARG\(TARG\) \!= sv\) \{
            if \(LvTARG\(TARG\)\)
                SvREFCNT\_dec\(LvTARG\(TARG\)\);
            LvTARG\(TARG\) = SvREFCNT\_inc\_simple\(sv\);
        \}

Yes

---BEGIN CODE--- my $str = 'Hello World';

for ($str\, "a") {   print Internals​::SvREFCNT($str)\, "\n";

  pos = 0;   print Internals​::SvREFCNT($str)\, "\n";

  pos = 0;   print Internals​::SvREFCNT($str)\, "\n";

  print "\n"; } ---END CODE---

---BEGIN ANNOTATED OUTPUT--- 2 3 1st pos's targ refers to $str 4 2nd pos's targ refers to $str

3 2 1st pos's targ no longer refers to $str 1 2nd pos's targ no longer refers to $str ---END ANNOTATED OUTPUT---

What if we avoided using TARG when a lvalue is needed? I'll produce a patch this weekend.

[p5pRT]

From @ikegami

On Thu Nov 05 12​:56​:29 2009\, perl@​profvince.com wrote​:

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

Confirmed for all four. A patch to add tests is attached.

A patch to fix the problem will follow shortly.

[p5pRT]

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch

```diff From 78180596da61dd9a1bf6bfad643c10e67a89cdeb Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @ikegami

On Fri Nov 06 16​:25​:33 2009\, ikegami@​adaelis.com wrote​:

On Thu Nov 05 12​:56​:29 2009\, perl@​profvince.com wrote​:

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

Confirmed for all four. A patch to add tests is attached.

A patch to fix the problem will follow shortly.

Two patches are attached.

The first adds tests. It's an updated version of my earlier patch. It should be used instead of the earlier patch.

The second plugs the leaks by not using TARG when a lvalue is required.

[p5pRT]

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch

```diff From b5752b4a862c33361c4df10856b3dd5f936886c7 Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @ikegami

0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patch

```diff From a9bc77a75d1c3c12ca59c2ef26c4382507775aa3 Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @demerphq

2009/11/7 Eric Brine via RT \perlbug\-followup@&#8203;perl\.org​:

On Fri Nov 06 16​:25​:33 2009\, ikegami@​adaelis.com wrote​:

On Thu Nov 05 12​:56​:29 2009\, perl@​profvince.com wrote​:

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

Confirmed for all four. A patch to add tests is attached.

A patch to fix the problem will follow shortly.

Two patches are attached.

The first adds tests. It's an updated version of my earlier patch. It should be used instead of the earlier patch.

The second plugs the leaks by not using TARG when a lvalue is required.

Just out of curiosity why does that code decontaminate differently in the two cases? One time it "decontaminates" taint and utf8\, and one time it just does taint. Is that a bug?

Yves

-- perl -Mre=debug -e "/just|another|perl|hacker/"

[p5pRT]

From @ikegami

On Sat\, Nov 7\, 2009 at 6​:13 PM\, yves orton via RT \<perlbug-followup@​perl.org

wrote​:

Just out of curiosity why does that code decontaminate differently in the two cases? One time it "decontaminates" taint and utf8\, and one time it just does taint. Is that a bug?

Some opcodes always return the result in the same SV to avoid having to create a new SV everytime the opcode is encountered. This SV is known as TARG.

The problem with these ops is 1) that they reference their last return value since they use TARG\, and 2) that their return value references one of the opcode's arguments when they are used as lvalues.

{   my $x = "abc"; # REFCOUNT($x) = 1 (pad)   substr($x\, 1\, 1) = "d"; # REFCOUNT($x) = 2 (pad\,substr)   print($x); # REFCOUNT($x) = 2 (pad\,substr) } # LEAK! # REFCOUNT($x) = 1 (substr)

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 lvalues\, making it so the arg never contains a reference to a variable.

Now to answer your question.

Before TARG is reused by the op\, it's untainted. There's no use untaintaing a freshly created variable\, and there's no use untainting TARG when TARG isn't used\, so I moved the untainting into the branch where TARG is used.

ELB

[p5pRT]

From @ikegami

[ Oops\, my previous message didn't answer your question. I had misread it. Let's try again ]

On Sat\, Nov 7\, 2009 at 6​:12 PM\, demerphq \demerphq@&#8203;gmail\.com wrote​:

Just out of curiosity why does that code decontaminate differently in the two cases? One time it "decontaminates" taint and utf8\, and one time it just does taint. Is that a bug?

Only one of the four ops plays with the UTF8 flag because three of the ops return numbers.

- ELB

[p5pRT]

From @rgarcia

2009/11/7 Eric Brine via RT \perlbug\-followup@&#8203;perl\.org​:

On Fri Nov 06 16​:25​:33 2009\, ikegami@​adaelis.com wrote​:

On Thu Nov 05 12​:56​:29 2009\, perl@​profvince.com wrote​:

It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe keys().

Confirmed for all four. A patch to add tests is attached.

A patch to fix the problem will follow shortly.

Two patches are attached.

The first adds tests. It's an updated version of my earlier patch. It should be used instead of the earlier patch.

The second plugs the leaks by not using TARG when a lvalue is required.

WIth this patch\, the following tests fail : re/substr.t (Wstat​: 65280 Tests​: 328 Failed​: 0)   Non-zero exit status​: 255   Parse errors​: Bad plan. You planned 334 tests but ran 328. op/sub_lval.t (Wstat​: 65280 Tests​: 56 Failed​: 0)   Non-zero exit status​: 255   Parse errors​: Bad plan. You planned 69 tests but ran 56. ../lib/warnings.t (Wstat​: 0 Tests​: 633 Failed​: 1)   Failed test​: 251

with the error "Can't return a temporary from lvalue subroutine". That happens in cases like that one : sub sstr : lvalue { substr($str\, 1\, 4) } It seems that we have a trade-off to make here. My opinion would be to apply your patch\, at the expense of forbidding that kind of leaky constructs. I'd like to hear comments here.

Also\, the warnings.t failure apparently is a bug fix rather than a true failure.

[p5pRT]

From perl@profvince.com

It seems that we have a trade-off to make here. My opinion would be to apply your patch\, at the expense of forbidding that kind of leaky constructs. I'd like to hear comments here.

I'm not too sure about this. I'd rather : - understand why ae389c8a29b487f4434c465442dfb611507a4a38 started incrementing the refcount of the LvTARG member ; - if it is decided to stop lvalues from propagating too far\, I'd rather keep those ops using the TARG and decrement its refcount in the magical callback.

Vincent.

[p5pRT]

From @ikegami

On Sun\, Nov 8\, 2009 at 8​:49 AM\, Vincent Pit \perl@&#8203;profvince\.com wrote​:

It seems that we have a trade-off to make here. My opinion would be to

apply your patch\, at the expense of forbidding that kind of leaky constructs. I'd like to hear comments here.

I'm not too sure about this. I'd rather : - understand why ae389c8a29b487f4434c465442dfb611507a4a38 started incrementing the refcount of the LvTARG member ; - if it is decided to stop lvalues from propagating too far\, I'd rather keep those ops using the TARG and decrement its refcount in the magical callback.

Can't​:

$x = \substr(...); print $$x; print $$x;

$x = \substr(...); $$x = uc($$x);

What about a weak reference. Is that possible? I haven't looked at how those work.

[p5pRT]

From @hvds

Rafael Garcia-Suarez \rgs@&#8203;consttype\.org wrote​: :2009/11/7 Eric Brine via RT \perlbug\-followup@&#8203;perl\.org​: :> On Fri Nov 06 16​:25​:33 2009\, ikegami@​adaelis.com wrote​: :>> On Thu Nov 05 12​:56​:29 2009\, perl@​profvince.com wrote​: :>> > It's not only lvalue vec()\, it's also lvalue pos()\, substr() and maybe :>> > keys(). :>> :>> Confirmed for all four. A patch to add tests is attached. :>> :>> A patch to fix the problem will follow shortly. :> :> Two patches are attached. :> :> The first adds tests. It's an updated version of my earlier patch. It :> should be used instead of the earlier patch. :> :> The second plugs the leaks by not using TARG when a lvalue is required. : :WIth this patch\, the following tests fail : [...] :with the error "Can't return a temporary from lvalue subroutine". :That happens in cases like that one : :sub sstr : lvalue { substr($str\, 1\, 4) } :It seems that we have a trade-off to make here. My opinion would be to :apply your patch\, at the expense of forbidding that kind of leaky :constructs. I'd like to hear comments here.

Is it possible to restrict the leak only to the lvalue-sub case? (In fact\, is it even a leak in that case?)

I feel it should be possible to have the best of both worlds.

Hugo

[p5pRT]

From @ikegami

On Sun\, Nov 8\, 2009 at 12​:21 PM\, Hugo van der Sanden via RT \< perlbug-followup@​perl.org> wrote​:

Is it possible to restrict the leak only to the lvalue-sub case? (In fact\, is it even a leak in that case?)

I feel it should be possible to have the best of both worlds.

As I understand it\, yes. That's the "LVRET" in "PL_op->op_flags & OPf_MOD || LVRET".

Considering the leak will probably never matter\, another option would be to simply not fix it.

[p5pRT]

From @ikegami

On Thu\, Jul 23\, 2009 at 7​:19 PM\, Kevin Ryde \perlbug\-followup@&#8203;perl\.orgwrote​:

# New Ticket Created by Kevin Ryde # Please include the string​: [perl #67838] # in the subject line of all future correspondence about this issue. # \<URL​: http​://rt.perl.org/rt3/Ticket/Display.html?id=67838 >

What's the impact of the bug?

substr\, pos and vec operate on strings. Delaying the freeing of strings has next to no impact. Problems can occur if the scalar containing the string is then repurposed (e.g. to hold an object with a destructor)\, but the odds of this occurring is probably next to nil.

keys operate on hashes. Delaying the freeing of a hash could have a significant impact. On the other hand\, lvalue keys is probably almost never used.

What's the impact of the fix?

Small slowdown due to the creation of a new SV for every lvalue call to these ops

Our options at this time​:

- Apply the provided patch\, even though it will cause returning substr/pos/vec/keys from an lvalue sub croaks. - Apply an adjusted patch that doesn't fix the leak when substr/pos/vec/keys are returned from an lvalue sub. - Don't fix until a better solution is found. - WONTFIX

[p5pRT]

From user42@zip.com.au

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

What's the impact of the bug?

Is that a question for me? As I said I didn't know if it was a bug\, a feature\, or a side-effect. It was just it looked a bit leak-like.

Delaying the freeing of strings has next to no impact.

If it's a big string it would use up memory for a lot longer than you'd expect. Ie. you thought you were careful to chuck that big string\, but it gets held onto.

If the scalar is tied or has other magic it could be bad to delay its destructor\, eg. a write-back of held data or something which otherwise end-of-scope normally handled. Sample programs below with tie and a File​::Map mmap() magic. (The mmap only holds up address space and system resources of course\, writes go through immediately.)

- Don't fix until a better solution is found.

I wouldn't mind knowing a way to identify scalars held alive like this\, so as to excuse them from Test​::Weaken or similar leak checking.

[p5pRT]

From user42@zip.com.au

tie.pl

[p5pRT]

From user42@zip.com.au

mmap.pl

[p5pRT]

From @ikegami

On Mon\, Nov 16\, 2009 at 4​:03 PM\, Kevin Ryde \user42@&#8203;zip\.com\.au wrote​:

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

What's the impact of the bug?

Is that a question for me?

It was rhetorical. The answer followed.

Delaying the freeing of strings has next to no impact.

If it's a big string it would use up memory for a lot longer than you'd expect.

Yes\, but Perl already does that all over the place intentionally. For example\, lexicals aren't freed when they go out of scope. They stay allocated (along with their string buffer) for reuse the next time that scope is entered. If that's the extent of the problem\, it's not a bug.

If the scalar is tied or has other magic it could be bad to delay its

destructor\,

I must have been tired\, but I forgot magic had destructors. I may have underestimated the impact. I definitely understated it.

- Don't fix until a better solution is found.

I wouldn't mind knowing a way to identify scalars held alive like this\, so as to excuse them from Test​::Weaken or similar leak checking.

Since TARG variables are stored in the pad\, you could go through the pad looking for PVLVs that have associated variables. It may not be the perfect answer (any maybe you can refine it by looking at the flags)\, but it should be a very good heuristic.

[p5pRT]

From @davidnicol

On Tue\, Nov 17\, 2009 at 12​:45 PM\, Eric Brine \ikegami@&#8203;adaelis\.com wrote​:

If the scalar is tied or has other magic it could be bad to delay its

destructor\,

I must have been tired\, but I forgot magic had destructors. I may have underestimated the impact. I definitely understated it.

- Don't fix until a better solution is found.

I wouldn't mind knowing a way to identify scalars held alive like this\, so as to excuse them from Test​::Weaken or similar leak checking.

Since TARG variables are stored in the pad\, you could go through the pad looking for PVLVs that have associated variables. It may not be the perfect answer (any maybe you can refine it by looking at the flags)\, but it should be a very good heuristic.

1​: are there situations where a RAIL object will be the subject of one of these functions? (resource acquisition is locking is the big design pattern that relies on timely destruction)

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 level to be the way to go. What's wrong with that suggestion? When does TARG hold the last reference to something\, and if never\, can TARG manipulation stuff simply leave reference counts alone?

-- "In the case of an infinite collection\, the question of the existence of a choice function is problematic"

[p5pRT]

From @ikegami

On Tue\, Nov 17\, 2009 at 2​:27 PM\, David Nicol \davidnicol@&#8203;gmail\.com wrote​:

1​: are there situations where a RAIL object will be the subject of one of these functions? (resource acquisition is locking is the big design pattern that relies on timely destruction)

Yes.

I previously gave the following example which demonstrates resources being help until global destruction (marked by "G") rather than being released timely​:

# Timely release

perl -le"{ my $x=''; $x = bless {}; } print 'G'; DESTROY { print 'D' }" D G

# Resource held until global destruction

perl -le"{ my $x=''; vec($x\,0\,1)=0; $x = bless {}; } print 'G'; DESTROY { print 'D' }" G D

Here's an example that uses lvalue keys(%h) in the most straightforward manner​:

perl -le'   sub init {   my %h;   keys(%h) = @​_;   %h = map { $_ => bless {} } @​_;   return \%h;   }   DESTROY { print "D" }   { my $h = init(qw(a b c)); }   print "G"; ' GDDD

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 level to be the way to go.

Yes\, I believe so.

What's wrong with that suggestion?

The only downside is overhead. It makes yet another variable magical (the var passed as an arg). I can write up a patch tonight if you wish.

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 we could do forgo ref counting. I don't think that's a condition we can meet.

Eric

[p5pRT]

From @ikegami

On Tue\, Nov 17\, 2009 at 6​:22 PM\, Eric Brine \ikegami@&#8203;adaelis\.com wrote​:

On Tue\, Nov 17\, 2009 at 2​:27 PM\, David Nicol \davidnicol@&#8203;gmail\.com wrote​:

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 level to be the way to go.

Yes\, I believe so.

No\, I was wrong. Conditions that must be met​:

  - A magical var (e.g. PVLV) must be returned.   - The magical var cannot be a TEMP   - The magical var must reference the arg var   - The magical var must have a counted reference to the arg var.

If the TARG is a PLVL that targets an RV that weekly references the arg var\, it violates the fourth point causing the following to fail​:

my $r; { my $s = ""; $r = \substr($s\, 0\, 1); } $$r = 'a'; print $$r;

If the TARG is an RV that weekly references a PVLV that references the arg var\, the PVLV would be a TEMP. That violates the second causing the following to fail​:

sub :lvalue { my $s = ""; substr($s\, 0\, 1) }->();

[p5pRT]

From @ikegami

On Wed\, Nov 18\, 2009 at 1​:01 PM\, Eric Brine \ikegami@&#8203;adaelis\.com wrote​:

My next step will be figuring out whether lvalue subs can't return TEMPs because it can't be done or because it hasn't been implemented.

It simply appears to be the case that the original coder forgot that TEMPs could be magical. No problem or memory leaks occur if they are returned.

In fact\, the sub was previously patched to allow a TEMP to be returned from an lvalue sub when it's a tied element. Without it\, the following would not work​:

use Tie​::Array; tie my @​a\, Tie​::StdArray​:: @​a = qw( a b c ); sub f :lvalue { $a[0] } f() = 'd';

Therefore\, the solution is to extend the aforementioned exception to SVs with any type of Set magic (instead of just those with tiedelem magic).

Attached is the test patch (unchanged) and an updated fix patch the addresses all problems and passes all tests.

- Eric

[p5pRT]

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch

```diff From feb04516ffd63b6754b734e167e97059107a0b85 Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @ikegami

0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patch

```diff From 45c6e6e3c52dc1824ecdc4edb329b373204bc0da Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From user42@zip.com.au

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

lexicals aren't freed when they go out of scope. They stay allocated (along with their string buffer) for reuse the next time that scope is entered.

Ah\, I didn't know that. Makes it hard to work carefully with big strings. You'd be tempted to free big things\, above some threshold\, on the relative badness of time taken to malloc a new block.

[p5pRT]

From @tux

On Fri\, 27 Nov 2009 11​:41​:19 +1100\, Kevin Ryde \user42@&#8203;zip\.com\.au wrote​:

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

lexicals aren't freed when they go out of scope. They stay allocated (along with their string buffer) for reuse the next time that scope is entered.

Ah\, I didn't know that. Makes it hard to work carefully with big strings. You'd be tempted to free big things\, above some threshold\, on the relative badness of time taken to malloc a new block.

$s = undef;

especially safe when $s is an object (e.g. a DBI statement handle) that may contain big structures.

-- H.Merijn Brand http​://tux.nl Perl Monger http​://amsterdam.pm.org/ using & porting perl 5.6.2\, 5.8.x\, 5.10.x\, 5.11.x on HP-UX 10.20\, 11.00\, 11.11\, 11.23\, and 11.31\, OpenSuSE 10.3\, 11.0\, and 11.1\, AIX 5.2 and 5.3. http​://mirrors.develooper.com/hpux/ http​://www.test-smoke.org/ http​://qa.perl.org http​://www.goldmark.org/jeff/stupid-disclaimers/

[p5pRT]

From Eirik-Berg.Hanssen@allverden.no

"H.Merijn Brand" \h\.m\.brand@&#8203;xs4all\.nl writes​:

On Fri\, 27 Nov 2009 11​:41​:19 +1100\, Kevin Ryde \user42@&#8203;zip\.com\.au wrote​:

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

lexicals aren't freed when they go out of scope. They stay allocated (along with their string buffer) for reuse the next time that scope is entered.

Ah\, I didn't know that. Makes it hard to work carefully with big strings. You'd be tempted to free big things\, above some threshold\, on the relative badness of time taken to malloc a new block.

$s = undef;

  Did you mean undef($s)\, or did something change while I was not looking? ;-)

Eirik\, who doesn't use that feature often either -- The price of success in philosophy is triviality.   -- C. Glymour.

[p5pRT]

From @tux

On Fri\, 27 Nov 2009 15​:38​:03 +0100\, Eirik Berg Hanssen \Eirik\-Berg\.Hanssen@&#8203;allverden\.no wrote​:

"H.Merijn Brand" \h\.m\.brand@&#8203;xs4all\.nl writes​:

On Fri\, 27 Nov 2009 11​:41​:19 +1100\, Kevin Ryde \user42@&#8203;zip\.com\.au wrote​:

"Eric Brine via RT" \perlbug\-followup@&#8203;perl\.org writes​:

lexicals aren't freed when they go out of scope. They stay allocated (along with their string buffer) for reuse the next time that scope is entered.

Ah\, I didn't know that. Makes it hard to work carefully with big strings. You'd be tempted to free big things\, above some threshold\, on the relative badness of time taken to malloc a new block.

$s = undef;

Did you mean undef($s)\, or did something change while I was not looking? ;-)

Both is allowed\, but indeed only 'undef ($x)' frees the variable. I was not aware of the difference until I just checked. Look at the flags​:

$ perl -MDP -wle'$_="x"x10;DDump$_;$_=undef;DDump$_' SV = PV(0x743158) at 0x782198   REFCNT = 1   FLAGS = (POK\,pPOK)   PV = 0x753660 "xxxxxxxxxx"\0   CUR = 10   LEN = 16

SV = PV(0x743158) at 0x782198   REFCNT = 1   FLAGS = ()   PV = 0x753660 "xxxxxxxxxx"\0   CUR = 10   LEN = 16

$ perl -MDP -wle'$_="x"x10;DDump$_;undef$_;DDump$_' SV = PV(0x743158) at 0x782198   REFCNT = 1   FLAGS = (POK\,pPOK)   PV = 0x753660 "xxxxxxxxxx"\0   CUR = 10   LEN = 16

SV = PV(0x743158) at 0x782198   REFCNT = 1   FLAGS = ()   PV = 0

$

Eirik\, who doesn't use that feature often either

-- H.Merijn Brand http​://tux.nl Perl Monger http​://amsterdam.pm.org/ using & porting perl 5.6.2\, 5.8.x\, 5.10.x\, 5.11.x on HP-UX 10.20\, 11.00\, 11.11\, 11.23\, and 11.31\, OpenSuSE 10.3\, 11.0\, and 11.1\, AIX 5.2 and 5.3. http​://mirrors.develooper.com/hpux/ http​://www.test-smoke.org/ http​://qa.perl.org http​://www.goldmark.org/jeff/stupid-disclaimers/

[p5pRT]

From @tux

On Sun\, 29 Nov 2009 00​:51​:49 +0100\, Eirik Berg Hanssen \Eirik\-Berg\.Hanssen@&#8203;allverden\.no wrote​:

On Fri\, Nov 27\, 2009 at 8​:52 AM\, H.Merijn Brand \h\.m\.brand@&#8203;xs4all\.nl wrote​:

On Fri\, 27 Nov 2009 15​:38​:03 +0100\, Eirik Berg Hanssen

  Did you mean undef($s)\, or did something change while I was not looking? ;-)

Both is allowed\, but indeed only 'undef ($x)' frees the variable.

If '$s = undef' is clearly not doing what might be expected\, is there any chance in breaking code when making '$s = undef' to do the same as 'undef $s' ?

How easy would it be to `optimize' that in perl itself?

Aside​: If anything were to change\, my suggestion would be the addition of a warning for an assignment\, the right hand side of which is a simple literal undef (without arguments\, parens or such). It is often a mistake and never the clearest way to write something​:

$x = undef; # unclear – did you really mean this? $x = (); # same thing\, clearer – yes\, I mean it undef $x; # not the same thing​: this frees the memory

@​x = undef; # unclear – did you really mean this? @​x = (undef); # same thing\, clearer – yes\, I mean it @​x = (); # not the same thing​: empty array undef @​x; # not the same thing​: this frees the memory

%x = undef; # unclear – did you really mean this? %x = ('' => undef); # same thing\, clearer – and no warning %x = (); # not the same thing​: empty hash undef %x; # not the same thing​: this frees the memory

($x\, @​y) = undef; # unclear – did you really mean this? ($x\, @​y) = (undef); # same thing\, clearer ($x\, @​y) = (); # also the same thing\, perhaps even clearer undef $x; undef @​y; # not the same thing​: this frees the memory

lsub($x) = undef; # ... okay\, I suppose that one is reasonably clear lsub($x) = (undef); # same thing\, even clearer ;-) undef lsub($x); # not the same thing ... but yes\, it works ;-)

... and at least the scalar case is a mistake that\, apparently\, even an experienced Perl hacker could make. ;-)

Eirik

-- H.Merijn Brand http​://tux.nl Perl Monger http​://amsterdam.pm.org/ using & porting perl 5.6.2\, 5.8.x\, 5.10.x\, 5.11.x on HP-UX 10.20\, 11.00\, 11.11\, 11.23\, and 11.31\, OpenSuSE 10.3\, 11.0\, and 11.1\, AIX 5.2 and 5.3. http​://mirrors.develooper.com/hpux/ http​://www.test-smoke.org/ http​://qa.perl.org http​://www.goldmark.org/jeff/stupid-disclaimers/

[p5pRT]

From user42@zip.com.au

"H.Merijn Brand" \h\.m\.brand@&#8203;xs4all\.nl writes​:

$s = undef;

Umm\, sounds a bit like hard work if you have to catch all variables that hold or might hold big things ... :-)

[p5pRT]

From @ikegami

On Sun\, Nov 29\, 2009 at 5​:11 AM\, H.Merijn Brand \h\.m\.brand@&#8203;xs4all\.nl wrote​:

If '$s = undef' is clearly not doing what might be expected\, is there any chance in breaking code when making '$s = undef' to do the same as 'undef $s' ?

No\, I don't see how it could.

How easy would it be to `optimize' that in perl itself?

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 scalar's buffer

1) When the result of a call to undef is assigned to it? 2) When &PL_sv_undef is assigned to it? 3) When an undefined value is assigned to it? 4) When an undefined value is assigned to it and when it is cleared (e.g. when it goes out of scope).

I'm not sure it's wise to remove this optimisation for the rare occurrence of accidentally using undef($var) instead of $var = undef in the rare occurrence that undef($var) is needed.

ELB

[p5pRT]

From @davidnicol

On Mon\, Nov 30\, 2009 at 2​:34 PM\, Eric Brine \ikegami@&#8203;adaelis\.com wrote​:

You mean remove the optimisation to prevent unnecessary calls to malloc. [... When?]

how about "when there's memory pressure?"

[p5pRT]

From @tux

On Mon\, 30 Nov 2009 15​:34​:08 -0500\, Eric Brine \ikegami@&#8203;adaelis\.com wrote​:

On Sun\, Nov 29\, 2009 at 5​:11 AM\, H.Merijn Brand \h\.m\.brand@&#8203;xs4all\.nl wrote​:

If '$s = undef' is clearly not doing what might be expected\, is there any chance in breaking code when making '$s = undef' to do the same as 'undef $s' ?

No\, I don't see how it could.

How easy would it be to `optimize' that in perl itself?

You mean remove the optimisation to prevent unnecessary calls to malloc.

I'm not pushing anymore\, but /I/ don't see *any* use here. If I want to preserve the allocated memory\, I use ""\, not undef.

The answer might depend on exactly what you want. Do you wish to free the scalar's buffer

1) When the result of a call to undef is assigned to it? 2) When &PL_sv_undef is assigned to it? 3) When an undefined value is assigned to it? 4) When an undefined value is assigned to it and when it is cleared (e.g. when it goes out of scope).

Yes to all four points\, but I'll change my habits.

I'm not sure it's wise to remove this optimisation for the rare occurrence of accidentally using undef ($var) instead of $var = undef in the rare occurrence that undef ($var) is needed.

I was looking from the other side. I used $s = undef *expecting* it to act as undef $s. I learned\, I'll change.

And jdb\, I'm not propagating people to undef all their values themselves. Out-of-scope is way nicer\, but I have seen places where using undef $sth would force a DESTROY that otherwise would have been too late.

-- H.Merijn Brand http​://tux.nl Perl Monger http​://amsterdam.pm.org/ using & porting perl 5.6.2\, 5.8.x\, 5.10.x\, 5.11.x on HP-UX 10.20\, 11.00\, 11.11\, 11.23\, and 11.31\, OpenSuSE 10.3\, 11.0\, and 11.1\, AIX 5.2 and 5.3. http​://mirrors.develooper.com/hpux/ http​://www.test-smoke.org/ http​://qa.perl.org http​://www.goldmark.org/jeff/stupid-disclaimers/

[p5pRT]

From @ikegami

On Mon\, Nov 30\, 2009 at 3​:58 PM\, H.Merijn Brand \h\.m\.brand@&#8203;xs4all\.nl wrote​:

I'm not pushing anymore\, but /I/ don't see *any* use here. If I want to preserve the allocated memory\, I use ""\, not undef.

The empty string is not the same thing as undef. You can't assign the empty string to variable you want to undefine.

And jdb\, I'm not propagating people to undef all their values themselves. Out-of-scope is way nicer

Variables going out of scope are not freed (if there are no external reference to them)\, and neither are their buffers.

$ perl -MDevel​::Peek -e'sub f { my $x; Dump $x; $x=$_[0]; Dump $x; } f "abcdef"; f "xyz";' SV = NULL(0x0) at 0x966c900   REFCNT = 1   FLAGS = (PADMY) SV = PV(0x96506d0) at 0x966c900   REFCNT = 1   FLAGS = (PADMY\,POK\,pPOK)   PV = 0x9667ed0 "abcdef"\0   CUR = 6   LEN = 8 SV = PV(0x96506d0) at 0x966c900   REFCNT = 1   FLAGS = (PADMY)   PV = 0x9667ed0 "abcdef"\0   CUR = 6   LEN = 8 SV = PV(0x96506d0) at 0x966c900   REFCNT = 1   FLAGS = (PADMY\,POK\,pPOK)   PV = 0x9667ed0 "xyz"\0   CUR = 3   LEN = 8

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 the fact that the reference in $sth probably has no string buffer to free in the first place\, if wouldn't affect anything's refcount if it did.

- ELB

[p5pRT]

From @davidnicol

perldoc -f undef could use a sentence discussing freeing large string buffers. maybe an example ten​:

10. $buf = undef; # defined($buf) is now false\, but $buf's memory space is intact for reuse!

[p5pRT]

From @iabyn

Eric notes that he has pending work on this ticket

[p5pRT]

From @ikegami

Hi\,

Attached are updated versions of patches submitted during the 5.12 prerelease freeze. They are rebased\, have more tests and remove a bit more dead code.

- Eric Brine

[p5pRT]

From @ikegami

0001-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patch

```diff From aabd9b21db75e6b3dd918ffa3d11fcfa5f66368f Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @ikegami

0002-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patch

```diff From bca7bab5acc5a0c7614cc747b641c9b7a58a143d Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```

[p5pRT]

From @ikegami

0003-TODO-tests-for-untimely-destruction-introduced-by-lv.patch

```diff From 2f670359e544907567eff1a3ee16ac8a76e90d98 Mon Sep 17 00:00:00 2001 From: Eric Brine 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 ```