Tests for the new custom op registrations.

2 files changed, 191 insertions, 0 deletions

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";