File Coverage

lib/Syntax/Keyword/Match.xs
Criterion Covered Total %
statement 169 178 94.9
branch 110 234 47.0
condition n/a
subroutine n/a
pod n/a
total 279 412 67.7


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, 2021-2023 -- 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 "XSParseKeyword.h"
13             #include "XSParseInfix.h"
14              
15             #define HAVE_PERL_VERSION(R, V, S) \
16             (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
17              
18             #include "hax/perl-backcompat.c.inc"
19              
20             #if HAVE_PERL_VERSION(5,32,0)
21             # define HAVE_OP_ISA
22             #endif
23              
24             #if HAVE_PERL_VERSION(5,18,0)
25             # define HAVE_BOOL_SvIV_please_nomg
26             #endif
27              
28             #if HAVE_PERL_VERSION(5,35,9)
29             # define HAVE_SV_NUMEQ_FLAGS
30             #endif
31              
32             #ifndef block_start
33             # define block_start(flags) Perl_block_start(aTHX_ flags)
34             #endif
35              
36             #ifndef block_end
37             # define block_end(floor, op) Perl_block_end(aTHX_ floor, op)
38             #endif
39              
40             #include "dispatchop.h"
41              
42             #ifndef HAVE_SV_NUMEQ_FLAGS
43             /* We'd like to call Perl_do_ncmp, except that isn't an exported API function
44             * Here's a near-copy of it for num-equality testing purposes */
45             #define do_numeq(left, right) S_do_numeq(aTHX_ left, right)
46 5           static bool S_do_numeq(pTHX_ SV *left, SV *right)
47             {
48             #ifndef HAVE_BOOL_SvIV_please_nomg
49             /* Before perl 5.18, SvIV_please_nomg() was void-returning */
50             SvIV_please_nomg(left);
51             SvIV_please_nomg(right);
52             #endif
53              
54 10 100         if(
55             #ifdef HAVE_BOOL_SvIV_please_nomg
56 9 50         SvIV_please_nomg(right) && SvIV_please_nomg(left)
    50          
    50          
    50          
    50          
57             #else
58             SvIOK(left) && SvIOK(right)
59             #endif
60             ) {
61             /* Compare as integers */
62 3 100         switch((SvUOK(left) ? 1 : 0) | (SvUOK(right) ? 2 : 0)) {
63             case 0: /* IV == IV */
64 0           return SvIVX(left) == SvIVX(right);
65              
66             case 1: /* UV == IV */
67             {
68 1           const IV riv = SvUVX(right);
69 1 50         if(riv < 0)
70             return 0;
71 1           return (SvUVX(left) == riv);
72             }
73              
74             case 2: /* IV == UV */
75             {
76 0           const IV liv = SvUVX(left);
77 0 0         if(liv < 0)
78             return 0;
79 0           return (liv == SvUVX(right));
80             }
81              
82             case 3: /* UV == UV */
83 2           return SvUVX(left) == SvUVX(right);
84             }
85             }
86             else {
87             /* Compare NVs */
88 2 50         NV const rnv = SvNV_nomg(right);
89 2 50         NV const lnv = SvNV_nomg(left);
90              
91 2           return lnv == rnv;
92             }
93 0           }
94             #endif
95              
96             #define newPADSVOP(type, flags, padix) MY_newPADSVOP(aTHX_ type, flags, padix)
97             static OP *MY_newPADSVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix)
98             {
99 81           OP *op = newOP(type, flags);
100 81           op->op_targ = padix;
101             return op;
102             }
103              
104 4           static OP *pp_dispatch_numeq(pTHX)
105             {
106 4           dDISPATCH;
107 4           dTARGET;
108             int idx;
109              
110 4 50         bool has_magic = SvAMAGIC(TARG);
    0          
    0          
111              
112 8 50         for(idx = 0; idx < n_cases; idx++) {
113 8           SV *val = values[idx];
114              
115             SV *ret;
116 8 50         if(has_magic &&
    0          
117             (ret = amagic_call(TARG, val, eq_amg, 0))) {
118 0 0         if(SvTRUE(ret))
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
119 0           return dispatch[idx];
120             }
121             #ifdef HAVE_SV_NUMEQ_FLAGS
122             else if(sv_numeq_flags(TARG, val, SV_SKIP_OVERLOAD))
123             #else
124             /* stolen from core's pp_hot.c / pp_eq() */
125 8 100         else if((SvIOK_notUV(TARG) && SvIOK_notUV(val)) ?
    50          
    100          
126 3           SvIVX(TARG) == SvIVX(val) : (do_numeq(TARG, val)))
127             #endif
128 4           return dispatch[idx];
129             }
130              
131 0           return cDISPATCHOP->op_other;
132             }
133              
134 1000012           static OP *pp_dispatch_streq(pTHX)
135             {
136 1000012           dDISPATCH;
137 1000012           dTARGET;
138             int idx;
139              
140 1000012 100         bool has_magic = SvAMAGIC(TARG);
    50          
    50          
141              
142 10000059 100         for(idx = 0; idx < n_cases; idx++) {
143 9000057           SV *val = values[idx];
144              
145             SV *ret;
146 9000057 100         if(has_magic &&
    50          
147             (ret = amagic_call(TARG, val, seq_amg, 0))) {
148 3 50         if(SvTRUE(ret))
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    100          
149 1           return dispatch[idx];
150             }
151 9000054 100         else if(sv_eq(TARG, val))
152 9           return dispatch[idx];
153             }
154              
155 1000002           return cDISPATCHOP->op_other;
156             }
157              
158             #ifdef HAVE_OP_ISA
159             static OP *pp_dispatch_isa(pTHX)
160             {
161             dDISPATCH;
162             dTARGET;
163             int idx;
164              
165             for(idx = 0; idx < n_cases; idx++)
166             if(sv_isa_sv(TARG, values[idx]))
167             return dispatch[idx];
168              
169             return cDISPATCHOP->op_other;
170             }
171             #endif
172              
173             struct MatchCaseBlock {
174             int n_cases;
175             OP **case_exprs;
176              
177             OP *op;
178             };
179              
180 51           static OP *build_cases_nondispatch(pTHX_ XSParseInfixInfo *matchinfo, PADOFFSET padix, struct MatchCaseBlock *block, OP *elseop)
181             {
182 51           size_t n_cases = block->n_cases;
183              
184             assert(n_cases);
185              
186             OP *testop = NULL;
187              
188             U32 i;
189 104 100         for(i = 0; i < n_cases; i++) {
190 53           OP *caseop = block->case_exprs[i];
191              
192             OP *thistestop;
193              
194 53           switch(matchinfo->opcode) {
195             #ifdef HAVE_OP_ISA
196             case OP_ISA:
197             #endif
198             case OP_SEQ:
199             case OP_EQ:
200 42           thistestop = newBINOP(matchinfo->opcode, 0,
201             newPADSVOP(OP_PADSV, 0, padix), caseop);
202 42           break;
203              
204             case OP_MATCH:
205 4 50         if(caseop->op_type != OP_MATCH || cPMOPx(caseop)->op_first)
    50          
206 0           croak("Expected a regexp match");
207             thistestop = caseop;
208             #if HAVE_PERL_VERSION(5,22,0)
209 4           thistestop->op_targ = padix;
210             #else
211             cPMOPx(thistestop)->op_first = newPADSVOP(OP_PADSV, 0, padix);
212             thistestop->op_flags |= OPf_KIDS|OPf_STACKED;
213             #endif
214 4           break;
215             case OP_CUSTOM:
216             thistestop = xs_parse_infix_new_op(matchinfo, 0,
217             newPADSVOP(OP_PADSV, 0, padix), caseop);
218 7           break;
219             }
220              
221 53 100         if(testop)
222 2           testop = newLOGOP(OP_OR, 0, testop, thistestop);
223             else
224             testop = thistestop;
225             }
226              
227             assert(testop);
228              
229 51 100         if(elseop)
230 33           return newCONDOP(0, testop, block->op, elseop);
231             else
232 18           return newLOGOP(OP_AND, 0, testop, block->op);
233             }
234              
235 8           static OP *build_cases_dispatch(pTHX_ OPCODE matchtype, PADOFFSET padix, size_t n_cases, struct MatchCaseBlock *blocks, OP *elseop)
236             {
237             assert(n_cases);
238             assert(matchtype != OP_MATCH);
239              
240             U32 blocki;
241              
242 8           ENTER;
243              
244 8           SV *valuessv = newSV(n_cases * sizeof(SV *));
245 8           SV *dispatchsv = newSV(n_cases * sizeof(OP *));
246 8           SAVEFREESV(valuessv);
247 8           SAVEFREESV(dispatchsv);
248              
249 8           SV **values = (SV **)SvPVX(valuessv);
250 8           OP **dispatch = (OP **)SvPVX(dispatchsv);
251              
252             DISPATCHOP *o = alloc_DISPATCHOP();
253 8           o->op_type = OP_CUSTOM;
254 8           o->op_targ = padix;
255              
256 8           switch(matchtype) {
257             #ifdef HAVE_OP_ISA
258             case OP_ISA: o->op_ppaddr = &pp_dispatch_isa; break;
259             #endif
260 3           case OP_SEQ: o->op_ppaddr = &pp_dispatch_streq; break;
261 5           case OP_EQ: o->op_ppaddr = &pp_dispatch_numeq; break;
262             }
263              
264 8           o->op_first = NULL;
265              
266 8           o->n_cases = n_cases;
267 8           o->values = values;
268 8           o->dispatch = dispatch;
269              
270 8           OP *retop = newUNOP(OP_NULL, 0, (OP *)o);
271              
272             U32 idx = 0;
273             blocki = 0;
274 38 100         while(n_cases) {
275 30           struct MatchCaseBlock *block = &blocks[blocki];
276              
277 30           U32 this_n_cases = block->n_cases;
278              
279 30           OP *blockop = block->op;
280 30 50         OP *blockstart = LINKLIST(blockop);
281 30           blockop->op_next = retop;
282              
283 30           n_cases -= this_n_cases;
284              
285 60 100         for(U32 casei = 0; casei < this_n_cases; casei++) {
286 30           OP *caseop = block->case_exprs[casei];
287              
288             assert(caseop->op_type == OP_CONST);
289 60           values[idx] = SvREFCNT_inc(cSVOPx(caseop)->op_sv);
290 30           op_free(caseop);
291              
292 30           dispatch[idx] = blockstart;
293              
294 30           idx++;
295             }
296              
297             /* TODO: link chain of siblings */
298              
299 30           blocki++;
300             }
301              
302 8 100         if(elseop) {
303 7 100         o->op_other = LINKLIST(elseop);
304 7           elseop->op_next = retop;
305             /* TODO: sibling linkage */
306             }
307             else {
308 1           o->op_other = retop;
309             }
310              
311             /* Steal the SV buffers */
312 8           SvPVX(valuessv) = NULL; SvLEN(valuessv) = 0;
313 8           SvPVX(dispatchsv) = NULL; SvLEN(dispatchsv) = 0;
314              
315 8           LEAVE;
316              
317 8           return retop;
318             }
319              
320 32           static int build_match(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata)
321             {
322             /* args:
323             * [0]: topic expression
324             * [1]: match type
325             * [2]: count of blocks
326             * [3]: count of case exprs = $N
327             * [4...]: $N * case exprs
328             * []: block
329             * [LAST]: default case if present
330             */
331             U32 argi = 0;
332              
333 32           OP *topic = args[argi++]->op;
334 32           XSParseInfixInfo *matchinfo = args[argi++]->infix;
335 32           int n_blocks = args[argi++]->i;
336              
337             /* Extract the raw args into a better data structure we can work with */
338             struct MatchCaseBlock *blocks;
339              
340 32 50         Newx(blocks, n_blocks, struct MatchCaseBlock);
341 32           SAVEFREEPV(blocks);
342              
343             int blocki;
344 113 100         for(blocki = 0; blocki < n_blocks; blocki++) {
345 81           struct MatchCaseBlock *block = &blocks[blocki];
346              
347 81           int n_cases = args[argi++]->i;
348              
349 81           block->n_cases = n_cases;
350              
351 81 50         Newx(block->case_exprs, n_cases, OP *);
352 81           SAVEFREEPV(block->case_exprs);
353              
354 164 100         for(int i = 0; i < n_cases; i++)
355 83           block->case_exprs[i] = args[argi++]->op;
356              
357 81           block->op = args[argi++]->op;
358             }
359              
360 32           bool has_default = args[argi]->i;
361             OP *o = NULL;
362 32 100         if(has_default)
363 13           o = args[argi + 1]->op;
364              
365 32           bool use_dispatch = hv_fetchs(GvHV(PL_hintgv), "Syntax::Keyword::Match/experimental(dispatch)", 0);
366              
367 32           I32 floor_ix = block_start(0);
368             /* The name is totally meaningless and never used, but if we don't set a
369             * name and instead use pad_alloc(SVs_PADTMP) then the peephole optimiser
370             * for aassign will crash
371             */
372 32           PADOFFSET padix = pad_add_name_pvs("$(Syntax::Keyword::Match/topic)", 0, NULL, NULL);
373 32           intro_my();
374              
375 32           OP *startop = newBINOP(OP_SASSIGN, 0,
376             topic, newPADSVOP(OP_PADSV, OPf_MOD|OPf_REF|(OPpLVAL_INTRO << 8), padix));
377 32           PL_hints |= HINT_BLOCK_SCOPE; /* ensures that op_scope() creates a full ENTER+LEAVE pair */
378              
379             int n_dispatch = 0;
380              
381 32           blocki = n_blocks-1;
382              
383             /* Roll up the blocks backwards, from end to beginning */
384 113 100         while(blocki >= 0) {
385 81           struct MatchCaseBlock *block = &blocks[blocki--];
386              
387 81           int n_cases = block->n_cases;
388              
389             /* perl expects a strict optree, where each block appears exactly once.
390             * We can't reĆ¼se the block between dispatch and non-dispatch ops, so
391             * we'll have to decide which strategy to use here
392             */
393             bool this_block_dispatch = use_dispatch;
394              
395 164 100         for(U32 casei = 0; casei < n_cases; casei++) {
396             /* TODO: forbid the , operator in the case label */
397 83           OP *caseop = block->case_exprs[casei];
398              
399 83           switch(matchinfo->opcode) {
400             #ifdef HAVE_OP_ISA
401             case OP_ISA:
402             /* bareword class names are permitted */
403             if(caseop->op_type == OP_CONST && caseop->op_private & OPpCONST_BARE)
404             caseop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
405             /* FALLTHROUGH */
406             #endif
407             case OP_SEQ:
408             case OP_EQ:
409 72 100         if(use_dispatch && caseop->op_type == OP_CONST)
    100          
410 30           continue;
411              
412             /* FALLTHROUGH */
413             case OP_MATCH:
414             case OP_CUSTOM:
415             this_block_dispatch = false;
416 53           break;
417             }
418             }
419              
420 81 100         if(this_block_dispatch) {
421 30           n_dispatch += n_cases;
422 30           continue;
423             }
424              
425 51 100         if(n_dispatch) {
426 1           o = build_cases_dispatch(aTHX_ matchinfo->opcode, padix,
427             n_dispatch, block + 1, o);
428             n_dispatch = 0;
429             }
430              
431 81           o = build_cases_nondispatch(aTHX_ matchinfo, padix, block, o);
432             }
433              
434 32 100         if(n_dispatch)
435 7           o = build_cases_dispatch(aTHX_ matchinfo->opcode, padix,
436             n_dispatch, blocks, o);
437              
438 32           *out = op_scope(block_end(floor_ix, newLISTOP(OP_LINESEQ, 0, startop, o)));
439              
440 32           return KEYWORD_PLUGIN_STMT;
441             }
442              
443             static const struct XSParseKeywordHooks hooks_match = {
444             .permit_hintkey = "Syntax::Keyword::Match/match",
445              
446             .pieces = (const struct XSParseKeywordPieceType []){
447             XPK_PARENSCOPE( /* ( EXPR : OP ) */
448             XPK_TERMEXPR_SCALARCTX,
449             XPK_COLON,
450             XPK_INFIX_MATCH_NOSMART
451             ),
452             XPK_BRACESCOPE( /* { blocks... } */
453             XPK_REPEATED( /* case (EXPR) {BLOCK} */
454             XPK_COMMALIST(
455             XPK_KEYWORD("case"),
456             XPK_PARENSCOPE( XPK_TERMEXPR_SCALARCTX )
457             ),
458             XPK_BLOCK
459             ),
460             XPK_OPTIONAL( /* default { ... } */
461             XPK_KEYWORD("default"),
462             XPK_BLOCK
463             )
464             ),
465             0,
466             },
467             .build = &build_match,
468             };
469              
470             #ifndef HAVE_OP_ISA
471             #include "hax/newOP_CUSTOM.c.inc"
472              
473             /* Can't use sv_isa_sv() because that was only added in 5.32 */
474 6           static bool S_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
475             {
476 6 50         if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
    50          
477             return FALSE;
478              
479             /* Also can't use GV_NOUNIVERSAL here because that also only turned up in 5.32 */
480 6           GV *isagv = gv_fetchmeth_pvn(SvSTASH(SvRV(sv)), "isa", 3, -1, 0);
481             /* This probably finds UNIVERSAL::isa; if so we can avoid it and just do it
482             * directly ourselves by calling sv_derived_from_sv()
483             */
484 6 50         if(isagv && !strEQ(HvNAME(GvSTASH(isagv)), "UNIVERSAL")) {
    50          
    50          
    50          
    0          
    50          
    50          
    100          
485 2           dSP;
486 2 50         CV *isacv = isGV(isagv) ? GvCV(isagv) : MUTABLE_CV(isagv);
487              
488             PUTBACK;
489              
490 2           ENTER;
491 2           SAVETMPS;
492              
493 2 50         EXTEND(SP, 2);
494 2 50         PUSHMARK(SP);
495 2           PUSHs(sv);
496 2           PUSHs(namesv);
497 2           PUTBACK;
498              
499 2           call_sv((SV *)isacv, G_SCALAR);
500              
501 2           SPAGAIN;
502 2           SV *retsv = POPs;
503 2 50         bool ret = SvTRUE(retsv);
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
504 2           PUTBACK;
505              
506 2 50         FREETMPS;
507 2           LEAVE;
508              
509 2           return ret;
510             }
511              
512 4           return sv_derived_from_sv(sv, namesv, 0);
513             }
514              
515 6           static OP *pp_isa(pTHX)
516             {
517 6           dSP;
518 6           SV *rhs = POPs;
519 6           SV *lhs = TOPs;
520              
521 6 100         SETs(boolSV(S_sv_isa_sv(aTHX_ lhs, rhs)));
522 6           RETURN;
523             }
524              
525 7           static OP *newop_isa(pTHX_ U32 flags, OP *lhs, OP *rhs, SV **parsedata, void *hookdata)
526             {
527             /* Avoid strictness failure on bareword RHS */
528 7 50         if(rhs->op_type == OP_CONST && rhs->op_private & OPpCONST_BARE)
    50          
529 7           rhs->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
530              
531 7           return newBINOP_CUSTOM(&pp_isa, flags, lhs, rhs);
532             }
533              
534             static const struct XSParseInfixHooks hooks_isa = {
535             .flags = 0,
536             .cls = XPI_CLS_ISA,
537              
538             .new_op = &newop_isa,
539             };
540             #endif
541              
542             MODULE = Syntax::Keyword::Match PACKAGE = Syntax::Keyword::Match
543              
544             BOOT:
545 14           boot_xs_parse_keyword(0.23);
546 14           boot_xs_parse_infix(0);
547              
548             register_xs_parse_keyword("match", &hooks_match, NULL);
549             #ifndef HAVE_OP_ISA
550             register_xs_parse_infix("isa", &hooks_isa, NULL);
551             #endif