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.

diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index 0b09641..5f61527 100644 (file)
--- 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 d985359..68df77f 100644 (file)
--- 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