From 309f449a439d154c7070327b4fa376bfce6b8a37 Mon Sep 17 00:00:00 2001
From: Mattia Barbon <mattia@barbon.org>
Date: Sat, 1 Nov 2014 20:49:07 +0100
Subject: [PATCH] Fix latent refcounting bug

It can be reproduced by enabling the Perl debugger inside a PSGI application:

    {
        package DB;

        sub DB { }
        sub sub { &$sub }
    }

    $^P = 0x73f;

    sub { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }

For every request the following warnings are emitted:

    Attempt to free unreferenced scalar: SV 0xfea6e8, Perl interpreter: 0xd534a0.
    Attempt to free unreferenced scalar: SV 0xfea718, Perl interpreter: 0xd534a0.

where the unreferenced scalars are the uwsgi::input/uwsgi::error instances
created in build_psgi_env.

The calling convention for Perl subroutines is that the values pushed on the
stack must be mortalized in the callee, and if the caller wants to retain them,
it must do a SvREFCNT_inc to undo the effect of the mortalization.

Before this patch XS_input/XS_error were not mortalizing the value, and
uwsgi_perl_obj_new was not incrementing the reference count, so the two bugs
balanced each other.

When running under debugger, Perl forwards all function/method calls to
DB::sub, which causes a mortal copy of the return value of
uwsgi::input/error::new to be pushed on the stack. The value is cleared by the
FREETMPS at the end of uwsgi_perl_obj_new, and the freed value is added to the
environment hash. The warning is emitted at the end of the request when the
environment hash is freed and Perl notices that some of the values has been
already freed.
---
 plugins/psgi/psgi_loader.c | 3 +++
 plugins/psgi/psgi_plugin.c | 2 +-
 2 files changed, 4 insertions(+), 1 deletion(-)

diff --git a/plugins/psgi/psgi_loader.c b/plugins/psgi/psgi_loader.c
index 82a42033..f759733b 100644
--- a/plugins/psgi/psgi_loader.c
+++ b/plugins/psgi/psgi_loader.c
@@ -30,6 +30,7 @@ XS(XS_error) {
 	else {
         	ST(0) = sv_bless(newRV_noinc(newSV(0)), ((HV **)wi->error)[0]);
 	}
+        sv_2mortal(ST(0));
         XSRETURN(1);
 }
 
@@ -46,6 +47,7 @@ XS(XS_input) {
 	else {
         	ST(0) = sv_bless(newRV_noinc(newSV(0)), ((HV **)wi->input)[0]);
 	}
+        sv_2mortal(ST(0));
         XSRETURN(1);
 }
 
@@ -85,6 +87,7 @@ XS(XS_stream)
 		else {
                 	ST(0) = sv_bless(newRV_noinc(newSV(0)), ((HV **)wi->stream)[0]);
 		}
+                sv_2mortal(ST(0));
                 XSRETURN(1);
 	}
 	else {
diff --git a/plugins/psgi/psgi_plugin.c b/plugins/psgi/psgi_plugin.c
index a764cb2c..7b39bf7c 100644
--- a/plugins/psgi/psgi_plugin.c
+++ b/plugins/psgi/psgi_plugin.c
@@ -114,7 +114,7 @@ SV *uwsgi_perl_obj_new(char *class, size_t class_len) {
 
 	SPAGAIN;
 
-	newobj = POPs;	
+	newobj = SvREFCNT_inc(POPs);
 	PUTBACK;
 	FREETMPS;
 	LEAVE;