Fix XS types in typemap in order to deal with references with get magics correctly

3 files changed, 112 insertions, 24 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 325681ab5a..71551ee696 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -2586,6 +2586,36 @@ CODE:
 }
 
 
+SV*
+take_svref(SVREF sv)
+CODE:
+    RETVAL = newRV_inc(sv);
+OUTPUT:
+    RETVAL
+
+SV*
+take_avref(AV* av)
+CODE:
+    RETVAL = newRV_inc((SV*)av);
+OUTPUT:
+    RETVAL
+
+SV*
+take_hvref(HV* hv)
+CODE:
+    RETVAL = newRV_inc((SV*)hv);
+OUTPUT:
+    RETVAL
+
+
+SV*
+take_cvref(CV* cv)
+CODE:
+    RETVAL = newRV_inc((SV*)cv);
+OUTPUT:
+    RETVAL
+
+
 BOOT:
 	{
 	HV* stash;
diff --git a/ext/XS-APItest/t/refs.t b/ext/XS-APItest/t/refs.t
new file mode 100755
index 0000000000..5755ddd086
--- /dev/null
+++ b/ext/XS-APItest/t/refs.t
@@ -0,0 +1,34 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use Tie::Scalar;
+
+use_ok('XS::APItest');
+
+my $a;
+my $sr = \$a;
+my $ar = [];
+my $hr = {};
+my $cr = sub{};
+
+is XS::APItest::take_svref($sr), $sr;
+is XS::APItest::take_avref($ar), $ar;
+is XS::APItest::take_hvref($hr), $hr;
+is XS::APItest::take_cvref($cr), $cr;
+
+my $obj = tie my $ref, 'Tie::StdScalar';
+${$obj} = $sr;
+is XS::APItest::take_svref($sr), $sr;
+
+${$obj} = $ar;
+is XS::APItest::take_avref($ar), $ar;
+
+${$obj} = $hr;
+is XS::APItest::take_hvref($hr), $hr;
+
+${$obj} = $cr;
+is XS::APItest::take_cvref($cr), $cr;
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index f88858762d..202425509c 100644
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -58,33 +58,57 @@ INPUT
 T_SV
 	$var = $arg
 T_SVREF
-	if (SvROK($arg))
-	    $var = (SV*)SvRV($arg);
-	else
-	    Perl_croak(aTHX_ \"%s: %s is not a reference\",
-			${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
-			\"$var\")
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv)){
+		    $var = SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
 T_AVREF
-	if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV)
-	    $var = (AV*)SvRV($arg);
-	else
-	    Perl_croak(aTHX_ \"%s: %s is not an array reference\",
-			${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
-			\"$var\")
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
+		    $var = (AV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
 T_HVREF
-	if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV)
-	    $var = (HV*)SvRV($arg);
-	else
-	    Perl_croak(aTHX_ \"%s: %s is not a hash reference\",
-			${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
-			\"$var\")
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
+		    $var = (AV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a HASH reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
 T_CVREF
-	if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV)
-	    $var = (CV*)SvRV($arg);
-	else
-	    Perl_croak(aTHX_ \"%s: %s is not a code reference\",
-			${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
-			\"$var\")
+	STMT_START {
+		SV* const xsub_tmp_sv = $arg;
+		SvGETMAGIC(xsub_tmp_sv);
+		if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){
+		    $var = (AV*)SvRV(xsub_tmp_sv);
+		}
+		else{
+		    Perl_croak(aTHX_ \"%s: %s is not a CODE reference\",
+				${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+				\"$var\");
+		}
+	} STMT_END
 T_SYSRET
 	$var NOT IMPLEMENTED
 T_UV