File Coverage

lib/List/Keywords.xs
Criterion Covered Total %
statement 361 374 96.5
branch 174 256 67.9
condition n/a
subroutine n/a
pod n/a
total 535 630 84.9


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             /* needed on latest perl to get optimize_optree/finalize_optree */
8             #define PERL_USE_VOLATILE_API
9              
10             #include "EXTERN.h"
11             #include "perl.h"
12             #include "XSUB.h"
13              
14             #include "XSParseKeyword.h"
15              
16             #include "perl-backcompat.c.inc"
17             #include "op_sibling_splice.c.inc"
18              
19             #ifndef optimize_optree
20             # if HAVE_PERL_VERSION(5,28,0)
21             # define optimize_optree(op) Perl_optimize_optree(aTHX_ op)
22             # else
23             # define optimize_optree(op)
24             # endif
25             #endif
26              
27             #ifndef finalize_optree
28             # if HAVE_PERL_VERSION(5,16,0)
29             # define finalize_optree(op) Perl_finalize_optree(aTHX_ op)
30             # else
31             # define finalize_optree(op)
32             # endif
33             #endif
34              
35             #if HAVE_PERL_VERSION(5,28,0)
36             # define XPUSHzero XPUSHs(&PL_sv_zero)
37             #else
38             /* perls before 5.28 do not have PL_sv_zero */
39             # define XPUSHzero mXPUSHi(0)
40             #endif
41              
42             /* We can't newLOGOP because that will force scalar context */
43             #define allocLOGOP_CUSTOM(func, flags, first, other) MY_allocLOGOP_CUSTOM(aTHX_ func, flags, first, other)
44             static LOGOP *MY_allocLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other)
45             {
46             LOGOP *logop;
47 70           NewOp(1101, logop, 1, LOGOP);
48              
49 70           logop->op_type = OP_CUSTOM;
50 70           logop->op_ppaddr = func;
51 70           logop->op_flags = OPf_KIDS | (U8)(flags);
52 70           logop->op_first = first;
53 70           logop->op_other = other;
54              
55             return logop;
56             }
57              
58 70           static OP *build_blocklist(pTHX_ PADOFFSET varix, OP *block, OP *list,
59             OP *(*pp_start)(pTHX), OP *(*pp_while)(pTHX), U8 op_private)
60             {
61             /* Follow the same optree shape as grep:
62             * LOGOP whileop
63             * LISTOP startop
64             * NULOP pushmark
65             * UNOP null
66             * {block scope goes here}
67             * ... {list values go here}
68             *
69             * the null op protects the block body from being executed initially,
70             * allowing it to be deferred
71             * whileop's ->op_other points at the start of the block
72             */
73              
74             /* Link block in execution order and remember its start */
75 70 50         OP *blockstart = LINKLIST(block);
76              
77             /* Hide the block inside an OP_NULL with no execution */
78 70           block = newUNOP(OP_NULL, 0, block);
79 70           block->op_next = block;
80              
81             /* Make startop op as the list with (shielded) block prepended */
82             OP *startop = list;
83 70 50         if(startop->op_type != OP_LIST)
84 70           startop = newLISTOP(OP_LIST, 0, startop, NULL);
85 70           op_sibling_splice(startop, cLISTOPx(startop)->op_first, 0, block);
86 70           startop->op_type = OP_CUSTOM;
87 70           startop->op_ppaddr = pp_start;
88 70           startop->op_targ = varix;
89              
90             LOGOP *whileop = allocLOGOP_CUSTOM(pp_while, 0, startop, blockstart);
91 70           whileop->op_private = startop->op_private = op_private;
92 70           whileop->op_targ = varix;
93              
94 70           OpLASTSIB_set(startop, (OP *)whileop);
95              
96             /* Temporarily set the whileop's op_next to NULL so as not to confuse
97             * a custom RPEEP that might be set. We'll store the real start value in
98             * there afterwards. See also
99             * https://rt.cpan.org/Ticket/Display.html?id=142471
100             */
101 70 50         OP *whilestart = LINKLIST(startop);
102 70           whileop->op_next = NULL;
103 70           startop->op_next = (OP *)whileop;
104 70           cUNOPx(block)->op_first->op_next = (OP *)whileop;
105              
106             /* Since the body of the block is now hidden from the peephole optimizer
107             * we'll have to run that manually now */
108             optimize_optree(block);
109 70           PL_rpeepp(aTHX_ blockstart);
110 70           finalize_optree(block);
111              
112 70           whileop->op_next = whilestart;
113 70           return (OP *)whileop;
114             }
115              
116             /* The same ppfuncs that implement `first` can also do `any` and `all` with
117             * minor changes of behaviour
118             */
119             enum {
120             FIRST_EMPTY_NO = (1<<0), /* \ */
121             FIRST_EMPTY_YES = (1<<1), /* - if neither, returns undef */
122             FIRST_RET_NO = (1<<2), /* \ */
123             FIRST_RET_YES = (1<<3), /* - if neither, returns $_ itself */
124             FIRST_STOP_ON_FALSE = (1<<4),
125             };
126              
127             static XOP xop_firststart;
128             static XOP xop_firstwhile;
129              
130 200038           static OP *pp_firststart(pTHX)
131             {
132             /* Insired by perl core's pp_grepstart() */
133 200038           dSP;
134 200038           PADOFFSET targ = PL_op->op_targ;
135              
136 200038 100         if(PL_stack_base + TOPMARK == SP) {
137             /* Empty */
138 9           U8 mode = PL_op->op_private;
139             (void)POPMARK;
140 9 50         XPUSHs((mode & FIRST_EMPTY_NO ) ? &PL_sv_no :
    100          
    100          
141             (mode & FIRST_EMPTY_YES) ? &PL_sv_yes :
142             &PL_sv_undef);
143 9           RETURNOP(PL_op->op_next->op_next);
144             }
145              
146 200029           PL_stack_sp = PL_stack_base + TOPMARK + 1;
147 200029 50         PUSHMARK(PL_stack_sp); /* current src item */
148              
149 200029           ENTER_with_name("first");
150              
151 400058           SV *src = PL_stack_base[TOPMARK];
152              
153 200029 100         if(SvPADTMP(src)) {
154 17           src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
155 17           PL_tmps_floor++;
156             }
157 200029           SvTEMP_off(src);
158              
159 200029 100         if(targ) {
160 6           SV **padentry = &PAD_SVl(targ);
161 6           save_sptr(padentry);
162 6           *padentry = SvREFCNT_inc(src);
163             }
164             else {
165 200023           SAVE_DEFSV;
166 200023           DEFSV_set(src);
167             }
168              
169 200029           PUTBACK;
170              
171             /* Jump to body of block */
172 200029           return (cLOGOPx(PL_op->op_next))->op_other;
173             }
174              
175 10200167           static OP *pp_firstwhile(pTHX)
176             {
177             /* Inspired by perl core's pp_grepwhile() */
178 10200167           dSP;
179 10200167           dPOPss;
180 10200167           U8 mode = PL_op->op_private;
181 10200167           PADOFFSET targ = PL_op->op_targ;
182 10200167 100         SV *targsv = targ ? PAD_SVl(targ) : DEFSV;
    50          
183              
184 10200167 50         bool ret = SvTRUE_NN(sv);
    50          
    0          
    0          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    0          
    0          
185              
186 10200167           (*PL_markstack_ptr)++;
187              
188 10200167 100         if((mode & FIRST_STOP_ON_FALSE) ? !ret : ret) {
    100          
189             /* Stop */
190              
191             /* Technically this means that `first` will not necessarily return the
192             * value from the list, but instead returns whatever the var was set to
193             * after the block has run; differing if the block modified it.
194             * I'm unsure how I feel about this, but both `CORE::grep` and
195             * `List::Util::first` do the same thing, so we are in good company
196             */
197 200020 100         SV *ret = (mode & FIRST_RET_NO ) ? &PL_sv_no :
198 200016 100         (mode & FIRST_RET_YES) ? &PL_sv_yes :
199             SvREFCNT_inc(targsv);
200 200020 100         if(targ)
201             SvREFCNT_dec(targsv);
202              
203 200020           LEAVE_with_name("first");
204             (void)POPMARK;
205 400040           SP = PL_stack_base + POPMARK;
206 200020           PUSHs(ret);
207 200020           RETURN;
208             }
209              
210 10000147 100         if(UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
211             /* Empty */
212 9           LEAVE_with_name("first");
213             (void)POPMARK;
214 18           SP = PL_stack_base + POPMARK;
215 9 100         PUSHs((mode & FIRST_EMPTY_NO ) ? &PL_sv_no :
    100          
216             (mode & FIRST_EMPTY_YES) ? &PL_sv_yes :
217             &PL_sv_undef);
218 9           RETURN;
219             }
220              
221 10000138           SV *src = PL_stack_base[TOPMARK];
222              
223 10000138 100         if(SvPADTMP(src)) {
224 132           src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
225 132           PL_tmps_floor++;
226             }
227 10000138           SvTEMP_off(src);
228              
229 10000138 100         if(targ) {
230 29           SV **padentry = &PAD_SVl(targ);
231 29           SvREFCNT_dec(*padentry);
232 29           *padentry = SvREFCNT_inc(src);
233             }
234             else
235 10000109           DEFSV_set(src);
236              
237 10000138           PUTBACK;
238              
239 10000138           return cLOGOP->op_other;
240             }
241              
242 45           static int build_first(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata)
243             {
244             size_t argi = 0;
245             PADOFFSET varix = 0;
246              
247 45           bool has_optvar = args[argi++]->i;
248 45 100         if(has_optvar) {
249 7           varix = args[argi++]->padix;
250             }
251              
252 45           OP *block = op_contextualize(op_scope(args[argi++]->op), G_SCALAR);
253 45           OP *list = args[argi++]->op;
254              
255 45 50         *out = build_blocklist(aTHX_ varix, block, list,
256 0           &pp_firststart, &pp_firstwhile, SvIV((SV *)hookdata));
257 45           return KEYWORD_PLUGIN_EXPR;
258             }
259              
260             static const struct XSParseKeywordPieceType pieces_optvar_blocklist[] = {
261             XPK_PREFIXED_BLOCK(
262             XPK_OPTIONAL(XPK_KEYWORD("my"), XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR))
263             ),
264             XPK_LISTEXPR_LISTCTX,
265             {0},
266             };
267              
268             static const struct XSParseKeywordHooks hooks_first = {
269             .permit_hintkey = "List::Keywords/first",
270              
271             .pieces = pieces_optvar_blocklist,
272             .build = &build_first,
273             };
274              
275             static const struct XSParseKeywordHooks hooks_any = {
276             .permit_hintkey = "List::Keywords/any",
277             .pieces = pieces_optvar_blocklist,
278             .build = &build_first,
279             };
280              
281             static const struct XSParseKeywordHooks hooks_all = {
282             .permit_hintkey = "List::Keywords/all",
283             .pieces = pieces_optvar_blocklist,
284             .build = &build_first,
285             };
286              
287             static const struct XSParseKeywordHooks hooks_none = {
288             .permit_hintkey = "List::Keywords/none",
289             .pieces = pieces_optvar_blocklist,
290             .build = &build_first,
291             };
292              
293             static const struct XSParseKeywordHooks hooks_notall = {
294             .permit_hintkey = "List::Keywords/notall",
295             .pieces = pieces_optvar_blocklist,
296             .build = &build_first,
297             };
298              
299             static XOP xop_reducestart;
300             static XOP xop_reducewhile;
301              
302             enum {
303             REDUCE_REDUCE,
304             REDUCE_REDUCTIONS,
305             };
306              
307 9           static OP *pp_reducestart(pTHX)
308             {
309 9           dSP;
310 9           U8 mode = PL_op->op_private;
311              
312 9 100         if(PL_stack_base + TOPMARK == SP) {
313             /* Empty */
314             (void)POPMARK;
315 2 50         if(GIMME_V == G_SCALAR)
    100          
316 1 50         XPUSHs(&PL_sv_undef);
317 2           RETURNOP(PL_op->op_next->op_next);
318             }
319              
320 7 100         if(PL_stack_base + TOPMARK + 1 == SP) {
321             /* Single item */
322             (void)POPMARK;
323             /* Leave the singleton there it will be fine */
324 2           RETURNOP(PL_op->op_next->op_next);
325             }
326              
327 5           PL_stack_sp = PL_stack_base + TOPMARK + 1;
328 5 100         if(mode == REDUCE_REDUCTIONS)
329 3 50         PUSHMARK(PL_stack_sp);
330 5 50         PUSHMARK(PL_stack_sp);
331              
332 5           ENTER_with_name("reduce");
333              
334 5           GV *firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV);
335 5           GV *secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV);
336              
337 5           save_gp(firstgv, 0); save_gp(secondgv, 0);
338 5           GvINTRO_off(firstgv); GvINTRO_off(secondgv);
339 5           SAVEGENERICSV(GvSV(firstgv)); SAVEGENERICSV(GvSV(secondgv));
340 10           SvREFCNT_inc(GvSV(firstgv)); SvREFCNT_inc(GvSV(secondgv));
341              
342             /* Initial accumulator */
343 10           SV *sv = PL_stack_base[TOPMARK];
344              
345 5 100         if(mode == REDUCE_REDUCTIONS)
346 3           PL_stack_base[PL_markstack_ptr[-1]++] = sv_mortalcopy(sv);
347              
348 5 50         if(SvPADTMP(sv)) {
349 5           sv = PL_stack_base[TOPMARK] = sv_mortalcopy(sv);
350 5           PL_tmps_floor++;
351             }
352 5           SvTEMP_off(sv);
353 10           GvSV(firstgv) = SvREFCNT_inc(sv);
354              
355 5           (*PL_markstack_ptr)++;
356              
357             /* value */
358 10           sv = PL_stack_base[TOPMARK];
359              
360 5 50         if(SvPADTMP(sv)) {
361 5           sv = PL_stack_base[TOPMARK] = sv_mortalcopy(sv);
362 5           PL_tmps_floor++;
363             }
364 5           SvTEMP_off(sv);
365 10           GvSV(secondgv) = SvREFCNT_inc(sv);
366              
367 5           PUTBACK;
368              
369             /* Jump to body of block */
370 5           return (cLOGOPx(PL_op->op_next))->op_other;
371             }
372              
373 18           static OP *pp_reducewhile(pTHX)
374             {
375 18           dSP;
376 18           U8 mode = PL_op->op_private;
377 18           dPOPss;
378              
379 18 100         if(mode == REDUCE_REDUCTIONS)
380 11 100         PL_stack_base[PL_markstack_ptr[-1]++] = SvPADTMP(sv) ? sv_mortalcopy(sv) : sv;
381              
382 18           (*PL_markstack_ptr)++;
383              
384 18 100         if(UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
385 5 50         U8 gimme = GIMME_V;
386 5           LEAVE_with_name("reduce");
387              
388 5 100         if(mode == REDUCE_REDUCTIONS) {
389             (void)POPMARK;
390 3           I32 retcount = --*PL_markstack_ptr - PL_markstack_ptr[-1];
391             (void)POPMARK;
392 6           SP = PL_stack_base + POPMARK;
393 3 100         if(gimme == G_SCALAR) {
394 1           SP[1] = SP[retcount];
395 1           SP += 1;
396             }
397 2 50         else if(gimme == G_ARRAY)
398 2           SP += retcount;
399             }
400             else {
401             (void)POPMARK;
402 4           SP = PL_stack_base + POPMARK;
403 2           PUSHs(SvREFCNT_inc(sv));
404             }
405 5           RETURN;
406             }
407              
408 13           GV *firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV);
409 13           GV *secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV);
410              
411 13           SvREFCNT_dec(GvSV(firstgv));
412 26           GvSV(firstgv) = SvREFCNT_inc(sv);
413              
414             /* next value */
415 26           sv = PL_stack_base[TOPMARK];
416              
417 13 50         if(SvPADTMP(sv)) {
418 13           sv = PL_stack_base[TOPMARK] = sv_mortalcopy(sv);
419 13           PL_tmps_floor++;
420             }
421 13           SvTEMP_off(sv);
422 26           GvSV(secondgv) = SvREFCNT_inc(sv);
423              
424 13           PUTBACK;
425              
426 13           return cLOGOP->op_other;
427             }
428              
429 10           static int build_reduce(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata)
430             {
431             #if !HAVE_PERL_VERSION(5,20,0)
432             GV *firstgv = gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV);
433             GV *secondgv = gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV);
434              
435             GvMULTI_on(firstgv);
436             GvMULTI_on(secondgv);
437             #endif
438              
439 10 50         *out = build_blocklist(aTHX_ 0, args[0]->op, args[1]->op,
440 0           &pp_reducestart, &pp_reducewhile, SvIV((SV *)hookdata));
441 10           return KEYWORD_PLUGIN_EXPR;
442             }
443              
444             static const struct XSParseKeywordPieceType pieces_blocklist[] = {
445             XPK_BLOCK_SCALARCTX,
446             XPK_LISTEXPR_LISTCTX,
447             {0},
448             };
449              
450             static const struct XSParseKeywordHooks hooks_reduce = {
451             .permit_hintkey = "List::Keywords/reduce",
452              
453             .pieces = pieces_blocklist,
454             .build = &build_reduce,
455             };
456              
457             static const struct XSParseKeywordHooks hooks_reductions = {
458             .permit_hintkey = "List::Keywords/reductions",
459              
460             .pieces = pieces_blocklist,
461             .build = &build_reduce,
462             };
463              
464             static XOP xop_ngrepstart;
465             static XOP xop_ngrepwhile;
466              
467             /* During the operation of ngrep, the top two marks on the markstack keep
468             * track of the input values and return values, respectively */
469             #define VALMARK (PL_markstack_ptr[0])
470             #define RETMARK (PL_markstack_ptr[-1])
471              
472 6           static OP *pp_ngrepstart(pTHX)
473             {
474             /* Inspired by perl core's pp_grepstart() */
475 6           dSP;
476 6           PADOFFSET targ = PL_op->op_targ;
477 6           U8 targcount = PL_op->op_private;
478              
479 6 100         if(PL_stack_base + TOPMARK == SP) {
480             /* Empty */
481             (void)POPMARK;
482 2 50         if(GIMME_V == G_SCALAR)
    100          
483 1 50         XPUSHzero;
484 2           RETURNOP(PL_op->op_next->op_next);
485             }
486              
487 4           PL_stack_sp = PL_stack_base + TOPMARK + 1;
488 4 50         PUSHMARK(PL_stack_sp);
489 4 50         PUSHMARK(PL_stack_sp);
490              
491 4           ENTER_with_name("ngrep");
492              
493 11 100         for(U8 targi = 0; targi < targcount; targi++) {
494 14           SV **svp = PL_stack_base + TOPMARK;
495 7 50         SV *sv = svp <= SP ? *svp : &PL_sv_undef;
496 7 50         if(SvPADTMP(sv)) {
497 0           sv = PL_stack_base[TOPMARK] = sv_mortalcopy(sv);
498 0           PL_tmps_floor++;
499             }
500 7           SvTEMP_off(sv);
501              
502 7           SV **padentry = &PAD_SVl(targ + targi);
503 7           save_sptr(padentry);
504 7           *padentry = SvREFCNT_inc(sv);
505              
506 7           VALMARK++;
507             }
508              
509 4           PUTBACK;
510              
511             /* Jump to body of block */
512 4           return (cLOGOPx(PL_op->op_next))->op_other;
513             }
514              
515 9           static OP *pp_ngrepwhile(pTHX)
516             {
517 9           dSP;
518 9           PADOFFSET targ = PL_op->op_targ;
519 9           U8 targcount = PL_op->op_private;
520 9           dPOPss;
521              
522 9 50         if(SvTRUE_NN(sv)) {
    50          
    0          
    0          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    0          
    0          
    100          
523             /* VALMARK has already been updated to point at next chunk;
524             * we'll have to look backwards */
525 7           SV **chunksvs = PL_stack_base + VALMARK - targcount;
526              
527 19 100         for(U8 targi = 0; targi < targcount; targi++) {
528 13 100         if(chunksvs + targi > SP)
529             break;
530              
531 12           PL_stack_base[RETMARK++] = chunksvs[targi];
532             }
533             }
534              
535 9 100         if(UNLIKELY(PL_stack_base + VALMARK > SP)) {
536 4 50         U8 gimme = GIMME_V;
537 4           I32 retcount = --RETMARK - PL_markstack_ptr[-2]; /* origmark */
538              
539 4           LEAVE_with_name("ngrep");
540              
541             (void)POPMARK;
542             (void)POPMARK;
543 8           SP = PL_stack_base + POPMARK;
544              
545 4 100         if(gimme == G_SCALAR) {
546             /* No need to X this because we know we consumed at least one stack item */
547 1           mPUSHi(retcount);
548             }
549 3 50         else if(gimme == G_LIST)
550 3           SP += retcount;
551              
552 4           RETURN;
553             }
554              
555             /* next round */
556              
557 15 100         for(U8 targi = 0; targi < targcount; targi++) {
558 10           SV **svp = PL_stack_base + VALMARK;
559 10 100         SV *sv = svp <= SP ? *svp : &PL_sv_undef;
560 10 50         if(SvPADTMP(sv)) {
561 0           sv = PL_stack_base[VALMARK] = sv_mortalcopy(sv);
562 0           PL_tmps_floor++;
563             }
564 10           SvTEMP_off(sv);
565              
566 10           SV **padentry = &PAD_SVl(targ + targi);
567 10           SvREFCNT_dec(*padentry);
568 10           *padentry = SvREFCNT_inc(sv);
569              
570 10           VALMARK++;
571             }
572              
573 5           PUTBACK;
574              
575 5           return cLOGOP->op_other;
576             }
577              
578             #undef VALMARK
579             #undef RETMARK
580              
581             static XOP xop_nmapstart;
582             static XOP xop_nmapwhile;
583              
584 7           static OP *pp_nmapstart(pTHX)
585             {
586             /* Inspired by perl core's pp_grepstart() */
587 7           dSP;
588 7           PADOFFSET targ = PL_op->op_targ;
589 7           U8 targcount = PL_op->op_private;
590              
591 7 100         if(PL_stack_base + TOPMARK == SP) {
592             /* Empty */
593             (void)POPMARK;
594 2 50         if(GIMME_V == G_SCALAR)
    100          
595 1 50         XPUSHzero;
596 2           RETURNOP(PL_op->op_next->op_next);
597             }
598              
599 5           PL_stack_sp = PL_stack_base + TOPMARK + 1;
600 5 50         PUSHMARK(PL_stack_sp);
601 5 50         PUSHMARK(PL_stack_sp);
602              
603 5           ENTER_with_name("nmap");
604              
605 5           SAVETMPS;
606              
607 5           ENTER_with_name("nmap_item");
608              
609 15 100         for(U8 targi = 0; targi < targcount; targi++) {
610 20           SV **svp = PL_stack_base + TOPMARK;
611 10 50         SV *sv = svp <= SP ? *svp : &PL_sv_undef;
612 10 50         if(SvPADTMP(sv)) {
613 0           sv = PL_stack_base[TOPMARK] = sv_mortalcopy(sv);
614 0           PL_tmps_floor++;
615             }
616 10           SvTEMP_off(sv);
617              
618 10           SV **padentry = &PAD_SVl(targ + targi);
619 10           save_sptr(padentry);
620 10           *padentry = SvREFCNT_inc(sv);
621              
622 10           (*PL_markstack_ptr)++;
623             }
624              
625 5           PUTBACK;
626              
627 5 50         PUSHMARK(PL_stack_sp);
628              
629             /* Jump to body of block */
630 5           return (cLOGOPx(PL_op->op_next))->op_other;
631             }
632              
633             /* During the operation of ngrep_while, the top three marks on the markstack
634             * keep track of the block result list, the input values, and the output
635             * values, respectively */
636             #define BLOCKMARK (PL_markstack_ptr[0])
637             #define VALMARK (PL_markstack_ptr[-1])
638             #define RETMARK (PL_markstack_ptr[-2])
639              
640 11           static OP *pp_nmapwhile(pTHX)
641             {
642             /* Inspired by perl core's pp_mapwhile() */
643 11           dSP;
644 11 50         U8 gimme = GIMME_V;
645 11           PADOFFSET targ = PL_op->op_targ;
646 11           U8 targcount = PL_op->op_private;
647              
648 11           I32 items = (SP - PL_stack_base) - BLOCKMARK;
649              
650 11 50         if(items && gimme != G_VOID) {
651 11 100         if(items > (VALMARK - RETMARK)) {
652 1           I32 shift = items - (VALMARK - RETMARK);
653 1           I32 count = (SP - PL_stack_base) - (VALMARK - targcount);
654             /* avoid needing to reshuffle the stack too often, even at the cost of
655             * making holes in it */
656 1 50         if(shift < count)
657             shift = count;
658              
659             /* make a hole 'shift' SV*s wide */
660 1 50         EXTEND(SP, shift);
    50          
661             SV **src = SP;
662 1           SV **dst = (SP += shift);
663 1           VALMARK += shift;
664 1           BLOCKMARK += shift;
665              
666             /* move the values up into it */
667 7 100         while(count--)
668 6           *(dst--) = *(src--);
669             }
670              
671 11           SV **dst = PL_stack_base + (RETMARK += items) - 1;
672              
673 11 100         if(gimme == G_LIST) {
674 8 50         EXTEND_MORTAL(items);
675 8           I32 tmpsbase = PL_tmps_floor + 1;
676 8 50         Move(PL_tmps_stack + tmpsbase, PL_tmps_stack + tmpsbase + items, PL_tmps_ix - PL_tmps_floor, SV *);
677 8           PL_tmps_ix += items;
678              
679             I32 i = items;
680 23 100         while(i-- > 0) {
681 15           SV *sv = POPs;
682 15 100         if(!SvTEMP(sv))
683 10           sv = sv_mortalcopy(sv);
684 15           *dst-- = sv;
685 15           PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
686             }
687 8           PL_tmps_floor += items;
688 8 50         FREETMPS;
689             i = items;
690 23 100         while(i-- > 0)
691 15           SvTEMP_on(PL_tmps_stack[--tmpsbase]);
692             }
693             else {
694             /* No point mortalcopying temporary values in scalar context */
695             I32 i = items;
696 9 100         while(i-- > 0) {
697 6           (void)POPs;
698 6           *dst-- = &PL_sv_undef;
699             }
700 3 50         FREETMPS;
701             }
702             }
703             else {
704 0 0         FREETMPS;
705             }
706              
707 11           LEAVE_with_name("nmap_item");
708              
709 11 100         if(UNLIKELY(PL_stack_base + VALMARK > SP)) {
710 5           I32 retcount = --RETMARK - PL_markstack_ptr[-3]; /* origmark */
711             (void)POPMARK;
712 5           LEAVE_with_name("nmap");
713              
714             (void)POPMARK;
715             (void)POPMARK;
716 10           SP = PL_stack_base + POPMARK;
717              
718 5 100         if(gimme == G_SCALAR) {
719             /* No need to X this because we know we consumed at least one stack item */
720 1           mPUSHi(retcount);
721             }
722 4 50         else if(gimme == G_LIST)
723 4           SP += retcount;
724              
725 5           RETURN;
726             }
727              
728             /* next round */
729              
730 6           ENTER_with_name("nmap_item");
731              
732 19 100         for(U8 targi = 0; targi < targcount; targi++) {
733 13           SV **svp = PL_stack_base + VALMARK;
734 13 50         SV *sv = svp <= SP ? *svp : &PL_sv_undef;
735 13 50         if(SvPADTMP(sv)) {
736 0           sv = PL_stack_base[VALMARK] = sv_mortalcopy(sv);
737 0           PL_tmps_floor++;
738             }
739 13           SvTEMP_off(sv);
740              
741 13           SV **padentry = &PAD_SVl(targ + targi);
742 13           SvREFCNT_dec(*padentry);
743 13           *padentry = SvREFCNT_inc(sv);
744              
745 13           VALMARK++;
746             }
747              
748 6           PUTBACK;
749              
750 6           return cLOGOP->op_other;
751             }
752              
753             #undef BLOCKMARK
754             #undef VALMARK
755             #undef RETMARK
756              
757             enum {
758             NITER_NGREP,
759             NITER_NMAP,
760             };
761              
762 15           static int build_niter(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata)
763             {
764             size_t argi = 0;
765 15           int varcount = args[argi++]->i;
766              
767             /* It's very unlikely but lets just check */
768 15 50         if(varcount > 255)
769 0           croak("Using more than 255 lexical variables to an iterated block function is not currently supported");
770              
771 15           PADOFFSET varix = args[argi++]->padix;
772             /* Because of how these vars were constructed, it really ought to be the
773             * case that they have consequitive padix values. Lets just check to be sure
774             */
775 29 100         for(int vari = 1; vari < varcount; vari++)
776 14 50         if(args[argi++]->padix != varix + vari)
777 0           croak("ARGH: Expected consequitive padix for lexical variables");
778              
779 15           OP *block = op_scope(args[argi++]->op);
780 15           OP *list = args[argi++]->op;
781              
782 15 50         switch(SvIV((SV *)hookdata)) {
783             case NITER_NGREP:
784 7           block = op_contextualize(block, G_SCALAR);
785 7           *out = build_blocklist(aTHX_ varix, block, list,
786             &pp_ngrepstart, &pp_ngrepwhile, (U8)varcount);
787 7           break;
788              
789             case NITER_NMAP:
790 8           block = op_contextualize(block, G_LIST);
791 8           *out = build_blocklist(aTHX_ varix, block, list,
792             &pp_nmapstart, &pp_nmapwhile, (U8)varcount);
793 8           break;
794             }
795 15           return KEYWORD_PLUGIN_EXPR;
796             }
797              
798             static const struct XSParseKeywordHooks hooks_ngrep = {
799             .permit_hintkey = "List::Keywords/ngrep",
800              
801             .pieces = (const struct XSParseKeywordPieceType []){
802             XPK_PREFIXED_BLOCK(
803             XPK_KEYWORD("my"),
804             XPK_PARENSCOPE(XPK_COMMALIST(XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR)))
805             ),
806             XPK_LISTEXPR_LISTCTX,
807             {0},
808             },
809             .build = &build_niter,
810             };
811              
812             static const struct XSParseKeywordHooks hooks_nmap = {
813             .permit_hintkey = "List::Keywords/nmap",
814              
815             .pieces = (const struct XSParseKeywordPieceType []){
816             XPK_PREFIXED_BLOCK(
817             XPK_KEYWORD("my"),
818             XPK_PARENSCOPE(XPK_COMMALIST(XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR)))
819             ),
820             XPK_LISTEXPR_LISTCTX,
821             {0},
822             },
823             .build = &build_niter,
824             };
825              
826             MODULE = List::Keywords PACKAGE = List::Keywords
827              
828             BOOT:
829 12           boot_xs_parse_keyword(0.05);
830              
831 12           register_xs_parse_keyword("first", &hooks_first, newSViv(0));
832              
833             /* Variations on first */
834 12           register_xs_parse_keyword("any", &hooks_any,
835             newSViv(FIRST_EMPTY_NO |FIRST_RET_YES));
836 12           register_xs_parse_keyword("all", &hooks_all,
837             newSViv(FIRST_EMPTY_YES|FIRST_RET_NO|FIRST_STOP_ON_FALSE));
838 12           register_xs_parse_keyword("none", &hooks_none,
839             newSViv(FIRST_EMPTY_YES|FIRST_RET_NO));
840 12           register_xs_parse_keyword("notall", &hooks_notall,
841             newSViv(FIRST_EMPTY_NO |FIRST_RET_YES|FIRST_STOP_ON_FALSE));
842              
843 12           XopENTRY_set(&xop_firststart, xop_name, "firststart");
844 12           XopENTRY_set(&xop_firststart, xop_desc, "first");
845 12           XopENTRY_set(&xop_firststart, xop_class, OA_LISTOP);
846 12           Perl_custom_op_register(aTHX_ &pp_firststart, &xop_firststart);
847              
848 12           XopENTRY_set(&xop_firstwhile, xop_name, "firstwhile");
849 12           XopENTRY_set(&xop_firstwhile, xop_desc, "first iter");
850 12           XopENTRY_set(&xop_firstwhile, xop_class, OA_LOGOP);
851 12           Perl_custom_op_register(aTHX_ &pp_firstwhile, &xop_firstwhile);
852              
853 12           register_xs_parse_keyword("reduce", &hooks_reduce, newSViv(REDUCE_REDUCE));
854 12           register_xs_parse_keyword("reductions", &hooks_reductions, newSViv(REDUCE_REDUCTIONS));
855              
856 12           XopENTRY_set(&xop_reducestart, xop_name, "reducestart");
857 12           XopENTRY_set(&xop_reducestart, xop_desc, "reduce");
858 12           XopENTRY_set(&xop_reducestart, xop_class, OA_LISTOP);
859 12           Perl_custom_op_register(aTHX_ &pp_reducestart, &xop_reducestart);
860              
861 12           XopENTRY_set(&xop_reducewhile, xop_name, "reducewhile");
862 12           XopENTRY_set(&xop_reducewhile, xop_desc, "reduce iter");
863 12           XopENTRY_set(&xop_reducewhile, xop_class, OA_LOGOP);
864 12           Perl_custom_op_register(aTHX_ &pp_reducewhile, &xop_reducewhile);
865              
866 12           register_xs_parse_keyword("ngrep", &hooks_ngrep, newSViv(NITER_NGREP));
867              
868 12           XopENTRY_set(&xop_ngrepstart, xop_name, "ngrepstart");
869 12           XopENTRY_set(&xop_ngrepstart, xop_desc, "ngrep");
870 12           XopENTRY_set(&xop_ngrepstart, xop_class, OA_LISTOP);
871 12           Perl_custom_op_register(aTHX_ &pp_ngrepstart, &xop_ngrepstart);
872              
873 12           XopENTRY_set(&xop_ngrepwhile, xop_name, "ngrepwhile");
874 12           XopENTRY_set(&xop_ngrepwhile, xop_desc, "ngrep iter");
875 12           XopENTRY_set(&xop_ngrepwhile, xop_class, OA_LOGOP);
876 12           Perl_custom_op_register(aTHX_ &pp_ngrepwhile, &xop_ngrepwhile);
877              
878 12           register_xs_parse_keyword("nmap", &hooks_nmap, newSViv(NITER_NMAP));
879              
880 12           XopENTRY_set(&xop_nmapstart, xop_name, "nmapstart");
881 12           XopENTRY_set(&xop_nmapstart, xop_desc, "nmap");
882 12           XopENTRY_set(&xop_nmapstart, xop_class, OA_LISTOP);
883 12           Perl_custom_op_register(aTHX_ &pp_nmapstart, &xop_nmapstart);
884              
885 12           XopENTRY_set(&xop_nmapwhile, xop_name, "nmapwhile");
886 12           XopENTRY_set(&xop_nmapwhile, xop_desc, "nmap iter");
887 12           XopENTRY_set(&xop_nmapwhile, xop_class, OA_LOGOP);
888 12           Perl_custom_op_register(aTHX_ &pp_nmapwhile, &xop_nmapwhile);