File Coverage

hax/make_argcheck_ops.c.inc
Criterion Covered Total %
statement 3 3 100.0
branch n/a
condition n/a
subroutine n/a
pod n/a
total 3 3 100.0


line stmt bran cond sub pod time code
1             /* vi: set ft=c : */
2              
3             #define make_croak_op(message) S_make_croak_op(aTHX_ message)
4             static OP *S_make_croak_op(pTHX_ SV *message)
5             {
6             #if HAVE_PERL_VERSION(5, 22, 0)
7             sv_catpvs(message, " at %s line %d.\n");
8             /* die sprintf($message, (caller)[1,2]) */
9             return op_convert_list(OP_DIE, 0,
10             op_convert_list(OP_SPRINTF, 0,
11             op_append_list(OP_LIST,
12             newSVOP(OP_CONST, 0, message),
13             newSLICEOP(0,
14             op_append_list(OP_LIST,
15             newSVOP(OP_CONST, 0, newSViv(1)),
16             newSVOP(OP_CONST, 0, newSViv(2))),
17             newOP(OP_CALLER, 0)))));
18             #else
19             /* For some reason I can't work out, the above tree isn't correct. Attempts
20             * to correct it still make OP_SPRINTF crash with "Out of memory!". For now
21             * lets just avoid the sprintf
22             */
23             sv_catpvs(message, "\n");
24             return newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
25             newSVOP(OP_CONST, 0, message));
26             #endif
27             }
28              
29             #if HAVE_PERL_VERSION(5, 26, 0)
30             # define HAVE_OP_ARGCHECK
31              
32             # include "make_argcheck_aux.c.inc"
33             #endif
34              
35             #define make_argcheck_ops(required, optional, slurpy, subname) S_make_argcheck_ops(aTHX_ required, optional, slurpy, subname)
36 6           static OP *S_make_argcheck_ops(pTHX_ int required, int optional, char slurpy, SV *subname)
37             {
38 6           int params = required + optional;
39              
40             #ifdef HAVE_OP_ARGCHECK
41             UNOP_AUX_item *aux = make_argcheck_aux(params, optional, slurpy);
42              
43 6           return op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL),
44             op_prepend_elem(OP_LINESEQ, newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux), NULL));
45             #else
46             /* Older perls lack the convenience of OP_ARGCHECK so we'll have to build an
47             * optree ourselves. For now we only support required + optional, no slurpy
48             *
49             * This code heavily inspired by Perl_parse_subsignature() in toke.c from perl 5.24
50             */
51              
52             OP *ret = NULL;
53              
54             if(required > 0) {
55             SV *message = newSVpvf("Too few arguments for subroutine '%" SVf "'", subname);
56             /* @_ >= required or die ... */
57             OP *checkop =
58             newSTATEOP(0, NULL,
59             newLOGOP(OP_OR, 0,
60             newBINOP(OP_GE, 0,
61             /* scalar @_ */
62             op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR),
63             newSVOP(OP_CONST, 0, newSViv(required))),
64             make_croak_op(message)));
65              
66             ret = op_append_list(OP_LINESEQ, ret, checkop);
67             }
68              
69             if(!slurpy) {
70             SV *message = newSVpvf("Too many arguments for subroutine '%" SVf "'", subname);
71             /* @_ <= (required+optional) or die ... */
72             OP *checkop =
73             newSTATEOP(0, NULL,
74             newLOGOP(OP_OR, 0,
75             newBINOP(OP_LE, 0,
76             /* scalar @_ */
77             op_contextualize(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), G_SCALAR),
78             newSVOP(OP_CONST, 0, newSViv(params))),
79             make_croak_op(message)));
80              
81             ret = op_append_list(OP_LINESEQ, ret, checkop);
82             }
83              
84             /* TODO: If slurpy is % then maybe complain about odd number of leftovers */
85              
86             return ret;
87             #endif
88             }