In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/dd698a052986b1a3b3a1969c7d44d0275ddb6939?hp=b2ef6d44c7d3e6463abb48b4fc82b08e88b5127a>
- Log ----------------------------------------------------------------- commit dd698a052986b1a3b3a1969c7d44d0275ddb6939 Author: Father Chrysostomos <[email protected]> Date: Fri Dec 10 22:12:48 2010 -0800 Fix some casts in typemap M lib/ExtUtils/typemap commit d257ec14259964174e602edb78bec9e5be422f97 Author: Father Chrysostomos <[email protected]> Date: Fri Dec 10 22:11:30 2010 -0800 Fix test count in ext/XS-APItest/t/refs.t M ext/XS-APItest/t/refs.t commit 190595c7bb804f65fc6934bdb76dcebcbb4904de Author: Father Chrysostomos <[email protected]> Date: Fri Dec 10 22:11:10 2010 -0800 Add ext/XS-APItest/t/refs.t to MANIFEST M MANIFEST commit 88b5a879c6c933e03b179ffd0a0ae87336c8afca Author: gfx <[email protected]> Date: Fri Dec 10 21:57:22 2010 -0800 Fix XS types in typemap in order to deal with references with get magics correctly M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/refs.t M lib/ExtUtils/typemap ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + ext/XS-APItest/APItest.xs | 30 ++++++++++++++++++ ext/XS-APItest/t/refs.t | 34 +++++++++++++++++++++ lib/ExtUtils/typemap | 72 ++++++++++++++++++++++++++++++--------------- 4 files changed, 113 insertions(+), 24 deletions(-) create mode 100755 ext/XS-APItest/t/refs.t diff --git a/MANIFEST b/MANIFEST index 63dc5de..4005645 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3462,6 +3462,7 @@ ext/XS-APItest/t/postinc.t test op_lvalue() ext/XS-APItest/t/printf.t XS::APItest extension ext/XS-APItest/t/ptr_table.t Test ptr_table_* APIs ext/XS-APItest/t/push.t XS::APItest extension +ext/XS-APItest/t/refs.t Test typemap ref handling ext/XS-APItest/t/rmagical.t XS::APItest extension ext/XS-APItest/t/rv2cv_op_cv.t test rv2cv_op_cv() API ext/XS-APItest/t/savehints.t test SAVEHINTS() API diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 325681a..71551ee 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 0000000..e71ca19 --- /dev/null +++ b/ext/XS-APItest/t/refs.t @@ -0,0 +1,34 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 9; + +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..c88238a 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 = (HV*)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 = (CV*)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 -- Perl5 Master Repository
