File Coverage

lib/Syntax/Operator/Is.xs
Criterion Covered Total %
statement 27 27 100.0
branch 6 6 100.0
condition n/a
subroutine n/a
pod n/a
total 33 33 100.0


line stmt bran cond sub pod time code
1             /* You may distribute under the terms of either the GNU General Public License
2             * or the Artistic License (the same terms as Perl itself)
3             *
4             * (C) Paul Evans, 2024 -- leonerd@leonerd.org.uk
5             */
6             #define PERL_NO_GET_CONTEXT
7              
8             #include "EXTERN.h"
9             #include "perl.h"
10             #include "XSUB.h"
11              
12             #include "XSParseInfix.h"
13              
14             #include "DataChecks.h"
15              
16             #define HAVE_PERL_VERSION(R, V, S) \
17             (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
18              
19             #include "newOP_CUSTOM.c.inc"
20              
21             /* Since Data::Checks v0.06, constraint functions are strongly const-folded so
22             * it is likely that the RHS of an `is` operator is a constant expression. If
23             * so, we'll compile it into a pp_static_is, an UNOP_AUX which stores the
24             * actual `struct DataChecks_Checker` instance stored in the aux pointer
25             */
26              
27 2           static OP *pp_dynamic_is(pTHX)
28             {
29 2           dSP;
30 2           SV *checkspec = POPs;
31 2           SV *value = POPs;
32              
33 2           struct DataChecks_Checker *checker = make_checkdata(checkspec);
34              
35 2 100         PUSHs(boolSV(check_value(checker, value)));
36              
37 2           free_checkdata(checker);
38              
39 2           RETURN;
40             }
41              
42             XOP xop_static_is;
43 3           static OP *pp_static_is(pTHX)
44             {
45 3           dSP;
46 3           SV *value = POPs;
47              
48 3           struct DataChecks_Checker *checker = (struct DataChecks_Checker *)cUNOP_AUX->op_aux;
49              
50 3 100         PUSHs(boolSV(check_value(checker, value)));
51              
52 3           RETURN;
53             }
54              
55 7           static OP *new_is_op(pTHX_ U32 flags, OP *lhs, OP *rhs, SV **parsedata, void *hookdata)
56             {
57 7 100         if(rhs->op_type != OP_CONST)
58 3           return newBINOP_CUSTOM(&pp_dynamic_is, flags, lhs, rhs);
59              
60 4           SV *checkspec = cSVOPx(rhs)->op_sv;
61 4           struct DataChecks_Checker *checker = make_checkdata(checkspec);
62              
63 4           return newUNOP_AUX_CUSTOM(&pp_static_is, flags, lhs, (UNOP_AUX_item *)checker);
64             }
65              
66             static const struct XSParseInfixHooks hooks_is = {
67             .cls = XPI_CLS_MATCH_MISC,
68             .permit_hintkey = "Syntax::Operator::Is/is",
69             .new_op = &new_is_op,
70             .ppaddr = &pp_dynamic_is,
71             };
72              
73             MODULE = Syntax::Operator::Is PACKAGE = Syntax::Operator::Is
74              
75             BOOT:
76 3           boot_xs_parse_infix(0.43);
77 3           boot_data_checks(0.06); /* const-folding */
78              
79 3           register_xs_parse_infix("Syntax::Operator::Is::is", &hooks_is, NULL);
80              
81 3           XopENTRY_set(&xop_static_is, xop_name, "static_is");
82 3           XopENTRY_set(&xop_static_is, xop_desc, "is operator (with static constraint)");
83 3           XopENTRY_set(&xop_static_is, xop_class, OA_UNOP_AUX);
84 3           Perl_custom_op_register(aTHX_ &pp_static_is, &xop_static_is);