3 #include "callchecker0.h"
4 #include "callparser.h"
7 typedef struct payload_St {
12 #define SVt_PADNAME SVt_PVMG
14 #ifndef COP_SEQ_RANGE_LOW_set
15 # define COP_SEQ_RANGE_LOW_set(sv,val) \
16 do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = val; } while(0)
17 # define COP_SEQ_RANGE_HIGH_set(sv,val) \
18 do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = val; } while(0)
19 #endif /* !COP_SEQ_RANGE_LOW_set */
21 #ifndef PERL_PADSEQ_INTRO
22 # define PERL_PADSEQ_INTRO I32_MAX
23 #endif /* !PERL_PADSEQ_INTRO */
25 #define pad_add_my_scalar_pvn(namepv, namelen) \
26 THX_pad_add_my_scalar_pvn(aTHX_ namepv, namelen)
28 THX_pad_add_my_scalar_pvn(pTHX_ char const *namepv, STRLEN namelen)
32 myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1);
33 offset = AvFILLp(PL_comppad);
35 PL_curpad = AvARRAY(PL_comppad);
36 namesv = newSV_type(SVt_PADNAME);
37 sv_setpvn(namesv, namepv, namelen);
38 COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax);
39 COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO);
41 av_store(PL_comppad_name, offset, namesv);
45 #define DEMAND_IMMEDIATE 0x00000001
46 #define DEMAND_NOCONSUME 0x00000002
47 #define demand_unichar(c, f) THX_demand_unichar(aTHX_ c, f)
49 THX_demand_unichar (pTHX_ I32 c, U32 flags)
51 if(!(flags & DEMAND_IMMEDIATE))
54 if(lex_peek_unichar(0) != c)
55 croak("syntax error");
57 if(!(flags & DEMAND_NOCONSUME))
68 myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp)
70 OP *condop, *blkop, *leaveop;
76 PERL_UNUSED_ARG(namegv);
77 PERL_UNUSED_ARG(flagsp);
79 demand_unichar('(', 0);
80 condop = parse_fullexpr(0);
81 demand_unichar(')', 0);
83 demand_unichar('{', DEMAND_NOCONSUME);
84 blk_floor = Perl_block_start(aTHX_ 1);
85 blkop = parse_block(0);
86 blkop = Perl_block_end(aTHX_ blk_floor, blkop);
88 topicalise = SvTRUE(*av_fetch((AV *)SvRV(args), 0, 0));
92 pvarop = newOP(OP_PADSV, 0);
93 pvarop->op_targ = pad_findmy_pvs("$Gather::Once::current_topic", 0);
95 if (pvarop->op_targ == NOT_IN_PAD)
96 croak("outside topicaliser"); /* FIXME */
98 condop = op_append_elem(OP_LIST, condop, pvarop);
101 predicate_cv_ref = *av_fetch((AV *)SvRV(args), 1, 0);
102 condop = newUNOP(OP_ENTERSUB, OPf_STACKED,
103 op_append_elem(OP_LIST, condop,
104 newCVREF(0, newSVOP(OP_CONST, 0,
105 SvREFCNT_inc(predicate_cv_ref)))));
107 OP *stub = newSTATEOP(0, NULL, newOP(OP_NULL, 0));
108 condop = newCONDOP(0, condop, blkop, stub);
109 condop->op_ppaddr = pp_stub_marker;
115 is_take_stmt (pTHX_ OP *stmt)
117 if (stmt->op_type != OP_LINESEQ
118 || !cLISTOPx(stmt)->op_last
119 || cLISTOPx(stmt)->op_last->op_type == OP_COND_EXPR)
122 OP *nullop = cLISTOPx(stmt)->op_last;
123 if (nullop->op_type != OP_NULL
124 || !(nullop->op_flags & OPf_KIDS)
125 || !cLISTOPx(nullop)->op_first
126 || nullop->op_ppaddr != pp_stub_marker)
129 OP *condop = cLISTOPx(nullop)->op_first;
130 if (condop->op_type != OP_COND_EXPR || !(condop->op_flags & OPf_KIDS))
134 OP *stub = condop->op_next; /* falseop */
140 myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp)
142 OP *topicaliser, *topblkop, *curblkop, *initop, *assignop;
145 PERL_UNUSED_ARG(namegv);
146 PERL_UNUSED_ARG(flagsp);
148 if (SvTRUE(topicalise)) {
149 demand_unichar('(', 0);
150 topicaliser = parse_fullexpr(0);
151 demand_unichar(')', 0);
154 demand_unichar('{', 0);
155 blk_floor = Perl_block_start(aTHX_ 1);
157 if (SvTRUE(topicalise)) {
158 initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
159 initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
160 sizeof("$Gather::Once::current_topic")-1);
162 assignop = newASSIGNOP(0, initop, 0, topicaliser);
165 topblkop = curblkop = parse_fullstmt(0);
167 while (lex_peek_unichar(0) != '}') {
168 OP *stub, *stmt = parse_fullstmt(0);
170 curblkop = op_append_elem(OP_LINESEQ, curblkop, stmt);
172 if ((stub = is_take_stmt(aTHX_ stmt))) {
173 curblkop = stub->op_next;
180 demand_unichar('}', DEMAND_IMMEDIATE);
182 if (SvTRUE(topicalise))
183 topblkop = op_prepend_elem(OP_LINESEQ, assignop, topblkop);
185 topblkop = op_scope(Perl_block_end(aTHX_ blk_floor, topblkop));
187 //return newGIVENOP(SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0),
188 //blkop, initop->op_targ);
194 myck_gathertake (pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
196 OP *rv2cvop, *pushop, *blkop;
198 PERL_UNUSED_ARG(namegv);
199 PERL_UNUSED_ARG(ckobj);
201 pushop = cUNOPx(entersubop)->op_first;
202 if (!pushop->op_sibling)
203 pushop = cUNOPx(pushop)->op_first;
205 blkop = pushop->op_sibling;
207 rv2cvop = blkop->op_sibling;
208 blkop->op_sibling = NULL;
209 pushop->op_sibling = rv2cvop;
215 MODULE = Gather::Once PACKAGE = Gather::Once
218 setup_gather_hook (CV *gather_cv, SV *topicalise)
220 cv_set_call_parser(gather_cv, myparse_args_gather, topicalise);
221 cv_set_call_checker(gather_cv, myck_gathertake, &PL_sv_undef);
224 setup_take_hook (CV *take_cv, SV *args)
226 cv_set_call_parser(take_cv, myparse_args_take, args);
227 cv_set_call_checker(take_cv, myck_gathertake, &PL_sv_undef);