Tests spew unreferenced scalar warnings #14618
Comments
From @cpansproutI just noticed this: ext/XS-Typemap/t/Typemap ...................................... Attempt to free unreferenced scalar: SV 0x7fd68ba42750 during global destruction. We need to fix it (or at least look into it) before 5.22. $ perl5.21.11 -V Characteristics of this binary (from libperl): -- Father Chrysostomos |
From @wolfsageOn Wed, Mar 25, 2015 at 12:22 PM, Father Chrysostomos
Hrm, I can't reproduce. I tried your configure args and also ./perl -Ilib -V Characteristics of this binary (from libperl): -- Matthew Horsfall (alh) |
|
The RT System itself - Status changed from 'new' to 'open' |
From @jkeenanOn Wed Mar 25 12:09:28 2015, alh wrote:
I tried both with and without -DDEBUGGING in an environment similar to alh's (Linux x86_64). I could not reproduce this warning, either. -- |
From @cpansproutOn Wed Mar 25 18:47:06 2015, jkeenan wrote:
That puts the onus on me to debug it, then. :-( I can reproduce this with multiple compilers and multiple configurations. Maybe it is Mac-specific. -- Father Chrysostomos |
From @tonycozOn Wed Mar 25 22:11:21 2015, sprout wrote:
I just tried to reproduce this on my Macs and didn't see the problem. My macs are running OS X 10.10.2 (uname -r 14.1.0) and 10.9.5 (13.4.0), from Tony |
From @bulk88On Wed Mar 25 22:11:21 2015, sprout wrote:
DEBUG_LEAKING_SCALARS+conditional breakpoints in SvREFCNT_dec and newSV (or equivelent), set on the absoolute ptr addr of the SV being in var sv. Atleast for me on Win32 Perl, SV*s are identical from run to run assuming all inputs/PP/XS code is the same. -- |
From @jkeenanOn Wed Mar 25 09:22:14 2015, sprout wrote:
FWIW, I was unable to reproduce these warnings on an older Darwin. -- |
From @jkeenanSummary of my perl5 (revision 5 version 21 subversion 11) configuration: Characteristics of this binary (from libperl): |
From @hvdsI'm able to reproduce this. Here are cut-down versions of the 4 cases: % PERL_DESTRUCT_LEVEL=2 ./perl -e '@INC = "lib"; { package XS::Typemap; require XSLoader; XSLoader::load() } XS::Typemap::T_STDIO_open("stdio.tmp")' % ./perl -Ilib -V Characteristics of this binary (from libperl): Not sure I know how to diagnose this, but here's a stack trace for the complaint on the first example: PERL_DESTRUCT_LEVEL=2 gdb ./perl Breakpoint 1, Perl_sv_free2 (sv=sv@entry=0x9815b0, rc=rc@entry=0) at sv.c:7069 I'm not sure how to determine what's actually being freed here, suggestions welcome. |
From @jkeenanOn Sat May 09 04:53:53 2015, hv wrote:
With the configuration attached, I could not reproduce your findings: ##### No error output in any of the 4 cases. Am I doing something wrong? Is my configuration significantly different from yours? Thank you very much. -- |
From @jkeenanSummary of my perl5 (revision 5 version 22 subversion 0) configuration: Characteristics of this binary (from libperl): |
From perl@profvince.com
You don't have DEBUGGING enabled, for starters. Vincent |
From @jkeenanOn Sat May 09 07:01:15 2015, perl@profvince.com wrote:
Yes, confirmed. ##### |
From @bulk88Confirmed on Win32 with DEBUGGING. C:\p521\srcpara>perl -Ilib -e " { package XS::Typemap; require XSLoader; XSLoade C:\p521\srcpara>perl -V d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=8, longdblki perllibs=oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg3 Characteristics of this binary (from libperl): C:\p521\srcpara> -- |
From @bulk88I am preparing a patch for this ticket. -- |
From @bulk88On Sat May 09 15:55:43 2015, bulk88 wrote:
stack traces of the SV * that caused "Attempt to free unreferenced scalar" created at + cop_file 0x008f6f34 "-e" char * perl521.dll!S_new_SV(interpreter * my_perl=0x003853cc, const char * file=0x282bd4ac, int line=5640, const char * func=0x282beb44) Line 348 C first dec event, but the SV on temp stack isn;t the one that gets double freed, the doublefreed one "is inside" the tmps stack one, I can't dump the SVs since p5p rejected this patch https://rt-archive.perl.org/perl5/Ticket/Display.html?id=121932 and I am on a virgin blead without my normal 30 patches applied, curcop is "-e" line 0 perl521.dll!Perl_sv_clear(interpreter * my_perl=0x003853cc, sv * const orig_sv=0x0093edfc) Line 6849 C /* unrolled SvREFCNT_dec and sv_free2 follows: */ if (!sv) 2nd dec event, now with "Attempt to free unreferenced scalar" perl521.dll!Perl_sv_free2(interpreter * my_perl=0x003853cc, sv * const sv=0x0094ad24, const unsigned long rc=0x00000000) Line 7071 C PERL_DESTRUCT_LEVEL = 2 didn't cause a crash for me on non-DEBUGGING for me, just "Attempt to free unreferenced" warnings, but there seems to be no way to capture or make fatal that to harness, those warnings that come from perl_destruct, but I did figure out another way to trigger the crash. I split it into 2 patches to be sure that Typemap.t fails reliably, perhaps some other people should smoke it with just the first patch to make sure it fails (and it randomly SEGVed for me on non-DEBUGGING) on platforms other than Win32. Maybe the 2 patches should be squashed into one for bisectablity or something. harness doesn't listen to STDERR, and a warning doesn't normally trigger a non-zero exit, and use warnings fatal doesn't seem to work inside perl_destruct (is that a bug?). Maybe those "panic" style internal warnings should be croaks/fatal, not warnings. Emitting a warning about guaranteed "memory corruption" and continuing execution even though the Perl VM is corrupt is a bit silly to me. A year or 2 ago khw did something that was causing unreferenced warnings on the George Win32 smoker but still passing for months until I spotted it one day while happening to watch a "make test" on my machine. The issue is nobody reviews the 1 MB smoke logs by eye and harness doesn't care about STDERR. Not only were the typemaps causing memory corruption, there were some other bugs and shoddy code with the typemap entries I fixed such as the typemap entries only working for RETVAL and not an outgoing @_ arg, using raw decimal numbers as flags instead of named constants flags, and duplicate hash lookups. -- |
From @bulk880001-add-test-that-fails-for-124181-to-Typemap.t.patchFrom 594d4089be5c8783f6fa1f53d315e4a701145d0a Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Sun, 10 May 2015 11:36:05 -0400
Subject: [PATCH 1/2] add test that fails for #124181 to Typemap.t
These tests will either fail with harness, and randomly SEGV for
me, which is intentional since they are testing memory
corruption.
---
ext/XS-Typemap/Typemap.pm | 4 ++--
ext/XS-Typemap/Typemap.xs | 9 +++++++++
ext/XS-Typemap/t/Typemap.t | 20 ++++++++++++++++++--
3 files changed, 29 insertions(+), 4 deletions(-)
diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm
index de3319b..a1ae021 100644
--- a/ext/XS-Typemap/Typemap.pm
+++ b/ext/XS-Typemap/Typemap.pm
@@ -36,7 +36,7 @@ require XSLoader;
use vars qw/ $VERSION @EXPORT /;
-$VERSION = '0.13';
+$VERSION = '0.14';
@EXPORT = (qw/
T_SV
@@ -76,7 +76,7 @@ $VERSION = '0.13';
T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short
T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct
T_ARRAY
- T_STDIO_open T_STDIO_close T_STDIO_print
+ T_STDIO_open T_STDIO_open_ret_in_arg T_STDIO_close T_STDIO_print
T_PACKED_in T_PACKED_out
T_PACKEDARRAY_in T_PACKEDARRAY_out
T_INOUT T_IN T_OUT
diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs
index 3fa0e74ab..8314cc2 100644
--- a/ext/XS-Typemap/Typemap.xs
+++ b/ext/XS-Typemap/Typemap.xs
@@ -906,6 +906,15 @@ T_STDIO_open( file )
OUTPUT:
RETVAL
+void
+T_STDIO_open_ret_in_arg( file, io)
+ const char * file
+ FILE * io = NO_INIT
+ CODE:
+ io = xsfopen( file );
+ OUTPUT:
+ io
+
SysRet
T_STDIO_close( f )
PerlIO * f
diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t
index 27b4086..49ac479 100644
--- a/ext/XS-Typemap/t/Typemap.t
+++ b/ext/XS-Typemap/t/Typemap.t
@@ -6,10 +6,11 @@ BEGIN {
}
}
-use Test::More tests => 152;
+use Test::More tests => 156;
use strict;
-use warnings;
+#catch WARN_INTERNAL type errors, and anything else unexpected
+use warnings FATAL => 'all';
use XS::Typemap;
pass();
@@ -213,6 +214,7 @@ is( T_PV("a string"), "a string");
is( T_PV(52), 52);
ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*';
{
+ use warnings NONFATAL => 'all';
my $uninit;
local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ };
() = ''.T_PV_null;
@@ -393,6 +395,16 @@ if (defined $fh) {
}
}
+$fh = "FOO";
+T_STDIO_open_ret_in_arg( $testfile, $fh);
+ok( $fh ne "FOO", 'return io in arg open succeeds');
+ok( print($fh "first line\n"), 'can print to return io in arg');
+ok( close($fh), 'can close return io in arg');
+$fh = "FOO";
+#now with a bad file name to make sure $fh is written to on failure
+T_STDIO_open_ret_in_arg( "", $fh);
+ok( !defined$fh, 'return io in arg open failed successfully');
+
# T_INOUT
note("T_INOUT");
SCOPE: {
@@ -439,6 +451,10 @@ SCOPE: {
ok(!close $fh2);
}
+# Perl RT #124181 SEGV due to double free in typemap
+# "Attempt to free unreferenced scalar"
+%{*{main::XS::}{HASH}} = ();
+
sub is_approx {
my ($l, $r, $n) = @_;
if (not defined $l or not defined $r) {
--
1.7.9.msysgit.0
|
From @bulk880002-fix-124181-double-free-refcnt-problems-in-IO-types-i.patchFrom a5ccb571fc79c106e20af7e9bf690ab98748c7de Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Sat, 9 May 2015 23:46:11 -0400
Subject: [PATCH 2/2] fix #124181 double free/refcnt problems in IO types in
typemap
commit 50e5165b96 "stop T_IN/OUT/INOUT/STDIO typemaps leaking" changed
newRV to newRV_noinc, but the GV * returned by newGVgen() is owned by the
package tree, like the SV * returned by get_sv(). Now when the RV to GV is
freed on mortal stack, the GV * in the package tree is freed, and now there
is a freed GV * in the package tree, if you turn on "PERL_DESTRUCT_LEVEL=2"
(and perhaps DEBUGGING is needed too), the package tree is destroyed SV *
by SV *, and perl will eventually warn with
"Attempt to free unreferenced scalar" which a very bad panic type warning.
Also fix the problem, that if this OUTPUT: type is being used for an
incoming arg, not the outgoing RETVAL arg, you can't assign a new SV*
ontop of the old one, that only works for perl stack return args, so
replace "$arg = &PL_sv_undef;" with "sv_setsv($arg, &PL_sv_undef);" if its
not RETVAL, this way OUTPUT on incoming args also works if it goes down the
error path. For efficiency, in a RETVAL siutation, let the undef original
SV* in $arg which is typically obtained from sv_newmortal() by xsubpp pass
through if we error out.
Also for efficiency, if it is RETVAL (which is more common) dont do the
sv_setsv/SvREFCNT_dec_NN stuff (2 function calls), just mortalize
(1 function call) the ex-temp RV and arrange for the RV to wind up on
perl stack.
Also, the GV * already knows what HV * stash it belongs to, so avoid the
stash lookup done by gv_stashpv() and just use GvSTASH which are simple
pointer derefs.
---
lib/ExtUtils/typemap | 48 ++++++++++++++++++++++++------------------------
1 files changed, 24 insertions(+), 24 deletions(-)
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index 831baad..5f61527 100644
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -389,47 +389,47 @@ T_STDIO
GV *gv = newGVgen("$Package");
PerlIO *fp = PerlIO_importFILE($var,0);
if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) {
- SV *rv = newRV_noinc((SV*)gv);
- rv = sv_bless(rv, gv_stashpv("$Package",1));
- sv_setsv($arg, rv);
- SvREFCNT_dec_NN(rv);
- }
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_IN
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) {
- SV *rv = newRV_noinc((SV*)gv);
- rv = sv_bless(rv, gv_stashpv("$Package",1));
- sv_setsv($arg, rv);
- SvREFCNT_dec_NN(rv);
- }
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_INOUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) {
- SV *rv = newRV_noinc((SV*)gv);
- rv = sv_bless(rv, gv_stashpv("$Package",1));
- sv_setsv($arg, rv);
- SvREFCNT_dec_NN(rv);
- }
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_OUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) {
- SV *rv = newRV_noinc((SV*)gv);
- rv = sv_bless(rv, gv_stashpv("$Package",1));
- sv_setsv($arg, rv);
- SvREFCNT_dec_NN(rv);
- }
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
--
1.7.9.msysgit.0
|
From @rjbsOn Sat May 09 15:55:43 2015, bulk88 wrote:
Could we get a review here? I'd like to know how we feel about getting this into RC1, which I'd like to get out the door in the next few days. -- |
From @iabynOn Fri, May 15, 2015 at 02:49:33PM -0700, Ricardo SIGNES via RT wrote:
I've just looked at it. I don't like it at all, from the perspective that, In more detail: Since perl 5.000 for T_IN, T_OUT, T_INOUT, and since 5.8.0 for T_STDIO, My commit 50e5165 of Dec 2014 fixed those leaks, but was Daniel's suggested change fixes that (changing the newRV_noinc back to I recommend that at this very late stage, we revert my 50e5165 commit I've submitted the revert for smoking: smoke-me/davem/rt124181. Failing that, we should do just the minimal fix of s/newRV_noinc/newRV_inc/, -- |
From @khwilliamsonOn 05/17/2015 01:00 PM, Dave Mitchell wrote:
Karl Williamson pushed to smoke-me/khw-revert50e5165b9 |
From @iabynOn Mon, May 18, 2015 at 08:42:57AM -0600, Karl Williamson wrote:
Later on in my email I said: I've submitted the revert for smoking: smoke-me/davem/rt124181. I'm assuming your smoke is an accidental duplicate of that??? -- |
From @khwilliamsonOn 05/18/2015 08:49 AM, Dave Mitchell wrote:
Yes. Sorry. |
From @iabynOn Mon, May 18, 2015 at 09:34:41AM -0600, Karl Williamson wrote:
No worries :-) My branch has smoked ok. I'll merge it sometime later this evening (GMT+1) -- |
From @iabynOn Mon, May 18, 2015 at 06:20:51PM +0100, Dave Mitchell wrote:
Now reverted with bae466e. -- |
From @bulk88Updated patches for blead/5.23. -- |
From @bulk880001-add-test-that-fails-for-124181-to-Typemap.t.patchFrom 1c8b0e23ba3b68cc69354e585bdfb7ec7518b6fe Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Sun, 10 May 2015 11:36:05 -0400
Subject: [PATCH 1/2] add test that fails for #124181 to Typemap.t
These tests will either fail with harness, and randomly SEGV for
me, which is intentional since they are testing memory
corruption.
---
ext/XS-Typemap/Typemap.pm | 4 ++--
ext/XS-Typemap/Typemap.xs | 9 +++++++++
ext/XS-Typemap/t/Typemap.t | 20 ++++++++++++++++++--
3 files changed, 29 insertions(+), 4 deletions(-)
diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm
index de3319b..a1ae021 100644
--- a/ext/XS-Typemap/Typemap.pm
+++ b/ext/XS-Typemap/Typemap.pm
@@ -36,7 +36,7 @@ require XSLoader;
use vars qw/ $VERSION @EXPORT /;
-$VERSION = '0.13';
+$VERSION = '0.14';
@EXPORT = (qw/
T_SV
@@ -76,7 +76,7 @@ $VERSION = '0.13';
T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short
T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct
T_ARRAY
- T_STDIO_open T_STDIO_close T_STDIO_print
+ T_STDIO_open T_STDIO_open_ret_in_arg T_STDIO_close T_STDIO_print
T_PACKED_in T_PACKED_out
T_PACKEDARRAY_in T_PACKEDARRAY_out
T_INOUT T_IN T_OUT
diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs
index 3fa0e74ab..8314cc2 100644
--- a/ext/XS-Typemap/Typemap.xs
+++ b/ext/XS-Typemap/Typemap.xs
@@ -906,6 +906,15 @@ T_STDIO_open( file )
OUTPUT:
RETVAL
+void
+T_STDIO_open_ret_in_arg( file, io)
+ const char * file
+ FILE * io = NO_INIT
+ CODE:
+ io = xsfopen( file );
+ OUTPUT:
+ io
+
SysRet
T_STDIO_close( f )
PerlIO * f
diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t
index 27b4086..49ac479 100644
--- a/ext/XS-Typemap/t/Typemap.t
+++ b/ext/XS-Typemap/t/Typemap.t
@@ -6,10 +6,11 @@ BEGIN {
}
}
-use Test::More tests => 152;
+use Test::More tests => 156;
use strict;
-use warnings;
+#catch WARN_INTERNAL type errors, and anything else unexpected
+use warnings FATAL => 'all';
use XS::Typemap;
pass();
@@ -213,6 +214,7 @@ is( T_PV("a string"), "a string");
is( T_PV(52), 52);
ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*';
{
+ use warnings NONFATAL => 'all';
my $uninit;
local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ };
() = ''.T_PV_null;
@@ -393,6 +395,16 @@ if (defined $fh) {
}
}
+$fh = "FOO";
+T_STDIO_open_ret_in_arg( $testfile, $fh);
+ok( $fh ne "FOO", 'return io in arg open succeeds');
+ok( print($fh "first line\n"), 'can print to return io in arg');
+ok( close($fh), 'can close return io in arg');
+$fh = "FOO";
+#now with a bad file name to make sure $fh is written to on failure
+T_STDIO_open_ret_in_arg( "", $fh);
+ok( !defined$fh, 'return io in arg open failed successfully');
+
# T_INOUT
note("T_INOUT");
SCOPE: {
@@ -439,6 +451,10 @@ SCOPE: {
ok(!close $fh2);
}
+# Perl RT #124181 SEGV due to double free in typemap
+# "Attempt to free unreferenced scalar"
+%{*{main::XS::}{HASH}} = ();
+
sub is_approx {
my ($l, $r, $n) = @_;
if (not defined $l or not defined $r) {
--
1.7.9.msysgit.0
|
From @bulk880002-fix-124181-double-free-refcnt-problems-in-IO-types-i.patchFrom 7afd92de70add9ddcab27b094be848c432e3ec32 Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Wed, 24 Jun 2015 15:48:12 -0400
Subject: [PATCH 2/2] fix #124181 double free/refcnt problems in IO types in
typemap
commit 50e5165b96 "stop T_IN/OUT/INOUT/STDIO typemaps leaking" changed
newRV to newRV_noinc, but the GV * returned by newGVgen() is owned by the
package tree, like the SV * returned by get_sv(). Now when the RV to GV is
freed on mortal stack, the GV * in the package tree is freed, and now there
is a freed GV * in the package tree, if you turn on "PERL_DESTRUCT_LEVEL=2"
(and perhaps DEBUGGING is needed too), the package tree is destroyed SV *
by SV *, and perl will eventually warn with
"Attempt to free unreferenced scalar" which a very bad panic type warning.
commit 50e5165b96 was reverted in commit bae466e878
"Revert "stop T_IN/OUT/INOUT/STDIO typemaps leaking" for 5.22's release
to stop the panic, but reintroduced the SV/RV leak. So fix the RV leak (the val
passed as source arg of sv_setsv) by freeing it after the copying. In a very
unlikely scenario, the RV could still leak if sv_setsv dies.
Also fix the problem, that if this OUTPUT: type is being used for an
incoming arg, not the outgoing RETVAL arg, you can't assign a new SV*
ontop of the old one, that only works for perl stack return args, so
replace "$arg = &PL_sv_undef;" with "sv_setsv($arg, &PL_sv_undef);" if its
not RETVAL, this way OUTPUT on incoming args also works if it goes down the
error path. For efficiency, in a RETVAL siutation, let the undef original
SV* in $arg which is typically obtained from sv_newmortal() by xsubpp pass
through if we error out.
Also for efficiency, if it is RETVAL (which is more common) dont do the
sv_setsv/SvREFCNT_dec_NN stuff (2 function calls), just mortalize
(1 function call) the ex-temp RV and arrange for the RV to wind up on
perl stack.
Also, the GV * already knows what HV * stash it belongs to, so avoid the
stash lookup done by gv_stashpv() and just use GvSTASH which are simple
pointer derefs.
---
lib/ExtUtils/typemap | 40 ++++++++++++++++++++++++++++------------
pod/perldelta.pod | 7 +++++++
2 files changed, 35 insertions(+), 12 deletions(-)
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index 0b09641..5f61527 100644
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -388,32 +388,48 @@ T_STDIO
{
GV *gv = newGVgen("$Package");
PerlIO *fp = PerlIO_importFILE($var,0);
- if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_IN
{
GV *gv = newGVgen("$Package");
- if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_INOUT
{
GV *gv = newGVgen("$Package");
- if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_OUT
{
GV *gv = newGVgen("$Package");
- if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &PL_sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 58ece4a..2a94b60 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -236,6 +236,13 @@ caused sub-threads in threaded -DPERL_TRACE_OPS builds to spew exceedingly
large op-counts at destruct. These counts would print %x as "ABABABAB",
clearly a mem-poison value.
+=item *
+
+A leak in the XS typemap caused one scalar to be leaked each time a C<FILE *>
+or a C<PerlIO *> was C<OUTPUT:>ed or imported to Perl, since perl 5.000. These
+particular typemap entries are thought to be extremely rarely used by XS
+modules. [perl #124181]
+
=back
=head1 Acknowledgements
--
1.7.9.msysgit.0
|
From @bulk88On Wed Jun 24 12:50:22 2015, bulk88 wrote:
Bump. -- |
From @tonycozOn Wed Jun 24 12:50:22 2015, bulk88 wrote:
Thanks, appled as c1b8440 and 7ed1d85. If you can put the perldelta changes in a separate patch (or just as prose in the ticket) it will simplify applying these changes, since perldelta sees a lot of churn. Thanks, |
|
@tonycoz - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#124181 (status was 'resolved')
Searchable as RT124181$
The text was updated successfully, but these errors were encountered: