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

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 325681a..71551ee 100644 (file)
--- 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;
 BOOT:
        {
        HV* stash;

diff --git a/ext/XS-APItest/t/refs.t b/ext/XS-APItest/t/refs.t
new file mode 100755 (executable)
index 0000000..5755ddd
--- /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 f888587..2024255 100644 (file)
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -58,33 +58,57 @@ INPUT
 T_SV
        $var = $arg
 T_SVREF
 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
 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
 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
 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
 T_SYSRET
        $var NOT IMPLEMENTED
 T_UV