From 7ed1d857c7b7016b9bde564c6802a4721d903d95 Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Wed, 24 Jun 2015 15:48:12 -0400 Subject: 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 | 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 and F are best summarized in L. =item * -XXX +A leak in the XS typemap caused one scalar to be leaked each time a C +or a C was Ced 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 -- cgit v1.2.1