1#!/usr/bin/perl
2
3use warnings;
4use strict;
5
6use Test::More tests => 25;
7use XS::APItest;
8
9my $ppaddr = xop_ppaddr;
10
11my $av = xop_build_optree;
12
13is $av->[2], "NAME:custom",     "unregistered XOPs have default name";
14is $av->[3], "DESC:unknown custom operator",
15                                "unregistered XOPs have default desc";
16is $av->[4], "CLASS:0",         "unregistered XOPs are BASEOPs";
17is scalar @$av, 5,              "unregistered XOPs don't call peep";
18
19my $names = xop_custom_op_names;
20$names->{$ppaddr} = "foo";
21$av = xop_build_optree;
22
23is $av->[2], "NAME:foo",        "PL_custom_op_names honoured";
24is $av->[3], "DESC:unknown custom operator",
25                                "PL_custom_op_descs can be empty";
26is $av->[4], "CLASS:0",         "class fallback still works";
27
28# this will segfault if the HV isn't there
29my $ops = xop_custom_ops;
30pass                            "PL_custom_ops created OK";
31
32my $descs = xop_custom_op_descs;
33$descs->{$ppaddr} = "bar";
34# this is not generally a supported operation
35delete $ops->{$ppaddr};
36$av = xop_build_optree;
37
38is $av->[3], "DESC:bar",        "PL_custom_op_descs honoured";
39
40my $xop = xop_my_xop;
41delete $ops->{$ppaddr};
42delete $names->{$ppaddr};
43delete $descs->{$ppaddr};
44xop_register;
45
46is $ops->{$ppaddr}, $xop,       "XOP registered OK";
47
48is xop_from_custom_op, $xop,    "XOP lookup from OP roundtrips";
49
50$av = xop_build_optree;
51my $OA_UNOP = xop_OA_UNOP;
52my ($unop, $kid) = ("???" x 2);
53
54# we can't use 'like', since that runs the match in a different scope
55# and so doesn't set $1
56ok $av->[0] =~ /unop:([0-9a-f]+)/,  "got unop address"
57    and $unop = $1;
58ok $av->[1] =~ /kid:([0-9a-f]+)/,   "got kid address"
59    and $kid = $1;
60
61is $av->[2], "NAME:my_xop",     "OP_NAME returns registered name";
62is $av->[3], "DESC:XOP for testing", "OP_DESC returns registered desc";
63is $av->[4], "CLASS:$OA_UNOP",  "OP_CLASS returns registered class";
64is scalar @$av, 7,              "registered peep called";
65is $av->[5], "peep:$unop",      "...with correct 'o' param";
66is $av->[6], "oldop:$kid",      "...and correct 'oldop' param";
67
68xop_clear;
69
70is $ops->{$ppaddr}, $xop,       "clearing XOP doesn't remove it";
71
72$av = xop_build_optree;
73
74is $av->[2], "NAME:custom",     "clearing XOP resets name";
75is $av->[3], "DESC:unknown custom operator",
76                                "clearing XOP resets desc";
77is $av->[4], "CLASS:0",         "clearing XOP resets class";
78is scalar @$av, 5,              "clearing XOP removes peep";
79
80ok test_newOP_CUSTOM(),
81  'newOP et al. do not fail assertions with OP_CUSTOM';
82