diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 115 | ||||
| -rw-r--r-- | ext/XS-APItest/t/customop.t | 76 |
3 files changed, 192 insertions, 0 deletions
@@ -3423,6 +3423,7 @@ ext/XS-APItest/t/call.t XS::APItest extension ext/XS-APItest/t/cleanup.t test stack behaviour on unwinding ext/XS-APItest/t/cophh.t test COPHH API ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API +ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 285fedffe5..60047ea47e 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -25,6 +25,7 @@ typedef struct { int peep_recording; AV *peep_recorder; AV *rpeep_recorder; + AV *xop_record; } my_cxt_t; START_MY_CXT @@ -901,6 +902,22 @@ static int my_keyword_plugin(pTHX_ } } +static XOP my_xop; + +static OP * +pp_xop(pTHX) +{ + return PL_op->op_next; +} + +static void +peep_xop(pTHX_ OP *o, OP *oldop) +{ + dMY_CXT; + av_push(MY_CXT.xop_record, newSVpvf("peep:%x", o)); + av_push(MY_CXT.xop_record, newSVpvf("oldop:%x", oldop)); +} + XS(XS_XS__APItest__XSUB_XS_VERSION_undef); XS(XS_XS__APItest__XSUB_XS_VERSION_empty); XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid); @@ -1358,6 +1375,104 @@ MODULE = XS::APItest PACKAGE = XS::APItest PROTOTYPES: DISABLE +HV * +xop_custom_ops () + CODE: + RETVAL = PL_custom_ops; + OUTPUT: + RETVAL + +HV * +xop_custom_op_names () + CODE: + PL_custom_op_names = newHV(); + RETVAL = PL_custom_op_names; + OUTPUT: + RETVAL + +HV * +xop_custom_op_descs () + CODE: + PL_custom_op_descs = newHV(); + RETVAL = PL_custom_op_descs; + OUTPUT: + RETVAL + +void +xop_register () + CODE: + XopENTRY_set(&my_xop, xop_name, "my_xop"); + XopENTRY_set(&my_xop, xop_desc, "XOP for testing"); + XopENTRY_set(&my_xop, xop_class, OA_UNOP); + XopENTRY_set(&my_xop, xop_peep, peep_xop); + Perl_custom_op_register(aTHX_ pp_xop, &my_xop); + +void +xop_clear () + CODE: + XopDISABLE(&my_xop, xop_name); + XopDISABLE(&my_xop, xop_desc); + XopDISABLE(&my_xop, xop_class); + XopDISABLE(&my_xop, xop_peep); + +IV +xop_my_xop () + CODE: + RETVAL = PTR2IV(&my_xop); + OUTPUT: + RETVAL + +IV +xop_ppaddr () + CODE: + RETVAL = PTR2IV(pp_xop); + OUTPUT: + RETVAL + +IV +xop_OA_UNOP () + CODE: + RETVAL = OA_UNOP; + OUTPUT: + RETVAL + +AV * +xop_build_optree () + CODE: + dMY_CXT; + UNOP *unop; + OP *kid; + + MY_CXT.xop_record = newAV(); + + kid = newSVOP(OP_CONST, 0, newSViv(42)); + + NewOp(1102, unop, 1, UNOP); + unop->op_type = OP_CUSTOM; + unop->op_ppaddr = pp_xop; + unop->op_flags = OPf_KIDS; + unop->op_private = 0; + unop->op_first = kid; + unop->op_next = NULL; + kid->op_next = (OP*)unop; + + av_push(MY_CXT.xop_record, newSVpvf("unop:%x", unop)); + av_push(MY_CXT.xop_record, newSVpvf("kid:%x", kid)); + + av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop))); + av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop))); + av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", OP_CLASS((OP*)unop))); + + PL_rpeepp(aTHX_ kid); + + FreeOp(kid); + FreeOp(unop); + + RETVAL = MY_CXT.xop_record; + MY_CXT.xop_record = NULL; + OUTPUT: + RETVAL + BOOT: { MY_CXT_INIT; diff --git a/ext/XS-APItest/t/customop.t b/ext/XS-APItest/t/customop.t new file mode 100644 index 0000000000..f2773f278b --- /dev/null +++ b/ext/XS-APItest/t/customop.t @@ -0,0 +1,76 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Test::More tests => 23; +use XS::APItest; + +my $ppaddr = xop_ppaddr; + +my $av = xop_build_optree; + +is $av->[2], "NAME:custom", "unregistered XOPs have default name"; +is $av->[3], "DESC:unknown custom operator", + "unregistered XOPs have default desc"; +is $av->[4], "CLASS:0", "unregistered XOPs are BASEOPs"; +is scalar @$av, 5, "unregistered XOPs don't call peep"; + +my $names = xop_custom_op_names; +$names->{$ppaddr} = "foo"; +$av = xop_build_optree; + +is $av->[2], "NAME:foo", "PL_custom_op_names honoured"; +is $av->[3], "DESC:unknown custom operator", + "PL_custom_op_descs can be empty"; +is $av->[4], "CLASS:0", "class fallback still works"; + +# this will segfault if the HV isn't there +my $ops = xop_custom_ops; +pass "PL_custom_ops created OK"; + +my $descs = xop_custom_op_descs; +$descs->{$ppaddr} = "bar"; +# this is not generally a supported operation +delete $ops->{$ppaddr}; +$av = xop_build_optree; + +is $av->[3], "DESC:bar", "PL_custom_op_descs honoured"; + +my $xop = xop_my_xop; +delete $ops->{$ppaddr}; +delete $names->{$ppaddr}; +delete $descs->{$ppaddr}; +xop_register; + +is $ops->{$ppaddr}, $xop, "XOP registered OK"; + +$av = xop_build_optree; +my $OA_UNOP = xop_OA_UNOP; +my ($unop, $kid) = ("???" x 2); + +# we can't use 'like', since that runs the match in a different scope +# and so doesn't set $1 +ok $av->[0] =~ /unop:([0-9a-f]+)/, "got unop address" + and $unop = $1; +ok $av->[1] =~ /kid:([0-9a-f]+)/, "got kid address" + and $kid = $1; + +is $av->[2], "NAME:my_xop", "OP_NAME returns registered name"; +is $av->[3], "DESC:XOP for testing", "OP_DESC returns registered desc"; +is $av->[4], "CLASS:$OA_UNOP", "OP_CLASS returns registered class"; +is scalar @$av, 7, "registered peep called"; +is $av->[5], "peep:$unop", "...with correct 'o' param"; +is $av->[6], "oldop:$kid", "...and correct 'oldop' param"; + +xop_clear; + +is $ops->{$ppaddr}, $xop, "clearing XOP doesn't remove it"; + +$av = xop_build_optree; + +is $av->[2], "NAME:custom", "clearing XOP resets name"; +is $av->[3], "DESC:unknown custom operator", + "clearing XOP resets desc"; +is $av->[4], "CLASS:0", "clearing XOP resets class"; +is scalar @$av, 5, "clearing XOP removes peep"; |