Commit | Line | Data |
14342f72 |
1 | #include "EXTERN.h" |
2 | #include "perl.h" |
3 | #include "callchecker0.h" |
4 | #include "callparser.h" |
5 | #include "XSUB.h" |
6 | |
7 | typedef struct payload_St { |
8 | bool topicalise; |
9 | CV *predicate_cv; |
10 | } payload_t; |
11 | |
12 | #define SVt_PADNAME SVt_PVMG |
13 | |
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 */ |
20 | |
21 | #ifndef PERL_PADSEQ_INTRO |
22 | # define PERL_PADSEQ_INTRO I32_MAX |
23 | #endif /* !PERL_PADSEQ_INTRO */ |
24 | |
25 | #define pad_add_my_scalar_pvn(namepv, namelen) \ |
26 | THX_pad_add_my_scalar_pvn(aTHX_ namepv, namelen) |
27 | static PADOFFSET |
28 | THX_pad_add_my_scalar_pvn(pTHX_ char const *namepv, STRLEN namelen) |
29 | { |
30 | PADOFFSET offset; |
31 | SV *namesv, *myvar; |
32 | myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1); |
33 | offset = AvFILLp(PL_comppad); |
34 | SvPADMY_on(myvar); |
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); |
40 | PL_cop_seqmax++; |
41 | av_store(PL_comppad_name, offset, namesv); |
42 | return offset; |
43 | } |
44 | |
45 | #define DEMAND_IMMEDIATE 0x00000001 |
46 | #define DEMAND_NOCONSUME 0x00000002 |
47 | #define demand_unichar(c, f) THX_demand_unichar(aTHX_ c, f) |
48 | static void |
49 | THX_demand_unichar (pTHX_ I32 c, U32 flags) |
50 | { |
51 | if(!(flags & DEMAND_IMMEDIATE)) |
52 | lex_read_space(0); |
53 | |
54 | if(lex_peek_unichar(0) != c) |
55 | croak("syntax error"); |
56 | |
57 | if(!(flags & DEMAND_NOCONSUME)) |
58 | lex_read_unichar(0); |
59 | } |
60 | |
14342f72 |
61 | static OP * |
83489a6b |
62 | pp_stub_marker (pTHX) |
14342f72 |
63 | { |
83489a6b |
64 | croak("FAIL"); |
14342f72 |
65 | } |
66 | |
67 | static OP * |
68 | myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp) |
69 | { |
70 | OP *condop, *blkop, *leaveop; |
71 | LOGOP *enterop; |
72 | SV *predicate_cv_ref; |
73 | int blk_floor; |
74 | bool topicalise; |
75 | |
76 | PERL_UNUSED_ARG(namegv); |
77 | PERL_UNUSED_ARG(flagsp); |
78 | |
79 | demand_unichar('(', 0); |
80 | condop = parse_fullexpr(0); |
81 | demand_unichar(')', 0); |
82 | |
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); |
87 | |
14342f72 |
88 | topicalise = SvTRUE(*av_fetch((AV *)SvRV(args), 0, 0)); |
89 | if (topicalise) { |
90 | OP *pvarop; |
91 | |
92 | pvarop = newOP(OP_PADSV, 0); |
83489a6b |
93 | pvarop->op_targ = pad_findmy_pvs("$Gather::Once::current_topic", 0); |
14342f72 |
94 | |
95 | if (pvarop->op_targ == NOT_IN_PAD) |
96 | croak("outside topicaliser"); /* FIXME */ |
97 | |
98 | condop = op_append_elem(OP_LIST, condop, pvarop); |
99 | } |
100 | |
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, |
83489a6b |
105 | SvREFCNT_inc(predicate_cv_ref))))); |
14342f72 |
106 | |
83489a6b |
107 | OP *stub = newSTATEOP(0, NULL, newOP(OP_NULL, 0)); |
108 | condop = newCONDOP(0, condop, blkop, stub); |
109 | condop->op_ppaddr = pp_stub_marker; |
14342f72 |
110 | |
83489a6b |
111 | return condop; |
14342f72 |
112 | } |
113 | |
114 | static OP * |
83489a6b |
115 | is_take_stmt (pTHX_ OP *stmt) |
14342f72 |
116 | { |
83489a6b |
117 | if (stmt->op_type != OP_LINESEQ |
118 | || !cLISTOPx(stmt)->op_last |
119 | || cLISTOPx(stmt)->op_last->op_type == OP_COND_EXPR) |
120 | return NULL; |
121 | |
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) |
127 | return NULL; |
128 | |
129 | OP *condop = cLISTOPx(nullop)->op_first; |
130 | if (condop->op_type != OP_COND_EXPR || !(condop->op_flags & OPf_KIDS)) |
131 | return NULL; |
132 | |
133 | return condop; |
134 | OP *stub = condop->op_next; /* falseop */ |
135 | |
136 | return stub; |
14342f72 |
137 | } |
138 | |
139 | static OP * |
140 | myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp) |
141 | { |
83489a6b |
142 | OP *topicaliser, *topblkop, *curblkop, *initop; |
14342f72 |
143 | int blk_floor; |
144 | |
145 | PERL_UNUSED_ARG(namegv); |
146 | PERL_UNUSED_ARG(flagsp); |
147 | |
148 | if (SvTRUE(topicalise)) { |
149 | demand_unichar('(', 0); |
150 | topicaliser = parse_fullexpr(0); |
151 | demand_unichar(')', 0); |
152 | } |
153 | |
83489a6b |
154 | demand_unichar('{', 0); |
14342f72 |
155 | blk_floor = Perl_block_start(aTHX_ 1); |
83489a6b |
156 | |
157 | initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8)); |
158 | initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic", |
159 | sizeof("$Gather::Once::current_topic")-1); |
160 | |
161 | topblkop = curblkop = parse_fullstmt(0); |
162 | lex_read_space(0); |
163 | while (lex_peek_unichar(0) != '}') { |
164 | OP *stub, *stmt = parse_fullstmt(0); |
165 | |
166 | curblkop = op_append_elem(OP_LINESEQ, curblkop, stmt); |
167 | |
168 | if ((stub = is_take_stmt(aTHX_ stmt))) { |
169 | curblkop = stub->op_next; |
170 | } |
171 | |
172 | //op_dump(curblkop); |
173 | lex_read_space(0); |
14342f72 |
174 | } |
175 | |
83489a6b |
176 | demand_unichar('}', DEMAND_IMMEDIATE); |
14342f72 |
177 | |
83489a6b |
178 | topblkop = op_prepend_elem(OP_LINESEQ, initop, topblkop); |
179 | topblkop = op_scope(Perl_block_end(aTHX_ blk_floor, topblkop)); |
14342f72 |
180 | |
83489a6b |
181 | //return newGIVENOP(SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0), |
182 | //blkop, initop->op_targ); |
183 | |
184 | return topblkop; |
14342f72 |
185 | } |
186 | |
187 | static OP * |
188 | myck_gathertake (pTHX_ OP *entersubop, GV *namegv, SV *ckobj) |
189 | { |
190 | OP *rv2cvop, *pushop, *blkop; |
191 | |
192 | PERL_UNUSED_ARG(namegv); |
193 | PERL_UNUSED_ARG(ckobj); |
194 | |
195 | pushop = cUNOPx(entersubop)->op_first; |
196 | if (!pushop->op_sibling) |
197 | pushop = cUNOPx(pushop)->op_first; |
198 | |
199 | blkop = pushop->op_sibling; |
200 | |
201 | rv2cvop = blkop->op_sibling; |
202 | blkop->op_sibling = NULL; |
203 | pushop->op_sibling = rv2cvop; |
204 | op_free(entersubop); |
205 | |
206 | return blkop; |
207 | } |
208 | |
209 | MODULE = Gather::Once PACKAGE = Gather::Once |
210 | |
211 | void |
212 | setup_gather_hook (CV *gather_cv, SV *topicalise) |
213 | CODE: |
214 | cv_set_call_parser(gather_cv, myparse_args_gather, topicalise); |
215 | cv_set_call_checker(gather_cv, myck_gathertake, &PL_sv_undef); |
216 | |
217 | void |
218 | setup_take_hook (CV *take_cv, SV *args) |
219 | CODE: |
220 | cv_set_call_parser(take_cv, myparse_args_take, args); |
221 | cv_set_call_checker(take_cv, myck_gathertake, &PL_sv_undef); |