Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

lvalue substr keeping lexical alive #9800

Closed
p5pRT opened this issue Jul 24, 2009 · 53 comments
Closed

lvalue substr keeping lexical alive #9800

p5pRT opened this issue Jul 24, 2009 · 53 comments
Labels

Comments

@p5pRT
Copy link
Collaborator

@p5pRT p5pRT commented Jul 24, 2009

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

Searchable as RT67838$

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 24, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 24, 2009

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 24, 2009

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/
15e7314..ae389c8​:/
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
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 24, 2009

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 5, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 5, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 5, 2009

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 5, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 5, 2009

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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 6, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

From @ikegami

0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 7, 2009

From @demerphq

2009/11/7 Eric Brine via RT <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

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@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

From @rgarcia

2009/11/7 Eric Brine via RT <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

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 ae389c8 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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

From @ikegami

On Sun, Nov 8, 2009 at 8​:49 AM, Vincent Pit <perl@​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 ae389c8 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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

From @hvds

Rafael Garcia-Suarez <rgs@​consttype.org> wrote​:
:2009/11/7 Eric Brine via RT <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 8, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 10, 2009

From @ikegami

On Thu, Jul 23, 2009 at 7​:19 PM, Kevin Ryde <perlbug-followup@​perl.org>wrote​:

# 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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

From user42@zip.com.au

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

From @ikegami

On Mon, Nov 16, 2009 at 4​:03 PM, Kevin Ryde <user42@​zip.com.au> wrote​:

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

From @davidnicol

On Tue, Nov 17, 2009 at 12​:45 PM, Eric Brine <ikegami@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 17, 2009

From @ikegami

On Tue, Nov 17, 2009 at 2​:27 PM, David Nicol <davidnicol@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 18, 2009

From @ikegami

On Tue, Nov 17, 2009 at 6​:22 PM, Eric Brine <ikegami@​adaelis.com> wrote​:

On Tue, Nov 17, 2009 at 2​:27 PM, David Nicol <davidnicol@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 22, 2009

From @ikegami

On Wed, Nov 18, 2009 at 1​:01 PM, Eric Brine <ikegami@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 22, 2009

From @ikegami

0001-Tests-to-detect-mem-leaks-in-lvalue-ops-RT-67838.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 22, 2009

From @ikegami

0002-Fix-mem-leaks-in-lvalue-ops-RT-67838.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 27, 2009

From user42@zip.com.au

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 27, 2009

From @Tux

On Fri, 27 Nov 2009 11​:41​:19 +1100, Kevin Ryde <user42@​zip.com.au>
wrote​:

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 27, 2009

From Eirik-Berg.Hanssen@allverden.no

"H.Merijn Brand" <h.m.brand@​xs4all.nl> writes​:

On Fri, 27 Nov 2009 11​:41​:19 +1100, Kevin Ryde <user42@​zip.com.au>
wrote​:

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 27, 2009

From @Tux

On Fri, 27 Nov 2009 15​:38​:03 +0100, Eirik Berg Hanssen
<Eirik-Berg.Hanssen@​allverden.no> wrote​:

"H.Merijn Brand" <h.m.brand@​xs4all.nl> writes​:

On Fri, 27 Nov 2009 11​:41​:19 +1100, Kevin Ryde <user42@​zip.com.au>
wrote​:

"Eric Brine via RT" <perlbug-followup@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 29, 2009

From @Tux

On Sun, 29 Nov 2009 00​:51​:49 +0100, Eirik Berg Hanssen
<Eirik-Berg.Hanssen@​allverden.no> wrote​:

On Fri, Nov 27, 2009 at 8​:52 AM, H.Merijn Brand <h.m.brand@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 30, 2009

From user42@zip.com.au

"H.Merijn Brand" <h.m.brand@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 30, 2009

From @ikegami

On Sun, Nov 29, 2009 at 5​:11 AM, H.Merijn Brand <h.m.brand@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 30, 2009

From @davidnicol

On Mon, Nov 30, 2009 at 2​:34 PM, Eric Brine <ikegami@​adaelis.com> wrote​:

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

how about "when there's memory pressure?"

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 30, 2009

From @Tux

On Mon, 30 Nov 2009 15​:34​:08 -0500, Eric Brine <ikegami@​adaelis.com>
wrote​:

On Sun, Nov 29, 2009 at 5​:11 AM, H.Merijn Brand <h.m.brand@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Nov 30, 2009

From @ikegami

On Mon, Nov 30, 2009 at 3​:58 PM, H.Merijn Brand <h.m.brand@​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
Copy link
Collaborator Author

@p5pRT p5pRT commented Dec 1, 2009

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Mar 16, 2010

From @iabyn

Eric notes that he has pending work on this ticket

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 31, 2010

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
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 31, 2010

From @ikegami

0001-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 31, 2010

From @ikegami

0002-Pure-Perl-lvalue-subs-can-t-return-temps-even-if-the.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 31, 2010

From @ikegami

0003-TODO-tests-for-untimely-destruction-introduced-by-lv.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Jul 31, 2010

From @ikegami

0004-Fix-untimely-destruction-introduced-by-lvalue-ops-RT.patch
From 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

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 13, 2010

From @rgarcia

On 31 July 2010 21​:27, Eric Brine <ikegami@​adaelis.com> wrote​:

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.

Thanks, applied to bleadperl.

@p5pRT
Copy link
Collaborator Author

@p5pRT p5pRT commented Aug 13, 2010

@rgs - Status changed from 'open' to 'resolved'

@p5pRT p5pRT closed this Aug 13, 2010
@p5pRT p5pRT added the Severity Low label Oct 18, 2019
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Linked pull requests

Successfully merging a pull request may close this issue.

None yet
1 participant
You can’t perform that action at this time.