diff options
author | Daniel Dragan <bulk88@hotmail.com> | 2015-06-24 15:48:12 -0400 |
---|---|---|
committer | Tony Cook <tony@develop-help.com> | 2015-07-08 10:55:07 +1000 |
commit | 7ed1d857c7b7016b9bde564c6802a4721d903d95 (patch) | |
tree | 3283bba2888a998b55f9d27d3fb31c0f51a61c5c | |
parent | c1b8440fca7358a5c52763ce726d40026870519c (diff) | |
download | perl-7ed1d857c7b7016b9bde564c6802a4721d903d95.tar.gz |
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.
-rw-r--r-- | lib/ExtUtils/typemap | 40 | ||||
-rw-r--r-- | pod/perldelta.pod | 5 |
2 files changed, 32 insertions, 13 deletions
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 0b09641f8d..5f61527dea 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 d9853597d2..68df77fbeb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -375,7 +375,10 @@ files in F<ext/> and F<lib/> are best summarized in L</Modules and Pragmata>. =item * -XXX +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 |