This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add lex_stuff_pvs()
[perl5.git] / ext / XS-APItest-KeywordRPN / KeywordRPN.xs
CommitLineData
88e1f1a2
JV
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
5#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
6#define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
7#define sv_is_string(sv) \
8 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
9 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
10
255fdf19 11static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
88e1f1a2
JV
12static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
13
14/* low-level parser helpers */
15
16#define PL_bufptr (PL_parser->bufptr)
17#define PL_bufend (PL_parser->bufend)
18
88e1f1a2
JV
19/* RPN parser */
20
21static OP *THX_parse_var(pTHX)
22{
f0e67a1d
Z
23 char *s = PL_bufptr;
24 char *start = s;
88e1f1a2
JV
25 PADOFFSET varpos;
26 OP *padop;
f0e67a1d 27 if(*s != '$') croak("RPN syntax error");
88e1f1a2 28 while(1) {
f0e67a1d 29 char c = *++s;
88e1f1a2 30 if(!isALNUM(c)) break;
88e1f1a2 31 }
f0e67a1d
Z
32 if(s-start < 2) croak("RPN syntax error");
33 lex_read_to(s);
34 {
35 /* because pad_findmy() doesn't really use length yet */
36 SV *namesv = sv_2mortal(newSVpvn(start, s-start));
37 varpos = pad_findmy(SvPVX(namesv), s-start, 0);
38 }
88e1f1a2 39 if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
394f6a09 40 croak("RPN only supports \"my\" variables");
88e1f1a2
JV
41 padop = newOP(OP_PADSV, 0);
42 padop->op_targ = varpos;
43 return padop;
44}
45#define parse_var() THX_parse_var(aTHX)
46
47#define push_rpn_item(o) \
48 (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
49#define pop_rpn_item() \
394f6a09 50 (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
88e1f1a2
JV
51 (tmpop = stack, stack = stack->op_sibling, \
52 tmpop->op_sibling = NULL, tmpop))
53
54static OP *THX_parse_rpn_expr(pTHX)
55{
56 OP *stack = NULL, *tmpop;
57 while(1) {
f0e67a1d
Z
58 I32 c;
59 lex_read_space(0);
60 c = lex_peek_unichar(0);
88e1f1a2
JV
61 switch(c) {
62 case /*(*/')': case /*{*/'}': {
63 OP *result = pop_rpn_item();
64 if(stack)
394f6a09 65 croak("RPN expression must return "
88e1f1a2
JV
66 "a single value");
67 return result;
68 } break;
69 case '0': case '1': case '2': case '3': case '4':
70 case '5': case '6': case '7': case '8': case '9': {
71 UV val = 0;
72 do {
f0e67a1d 73 lex_read_unichar(0);
88e1f1a2 74 val = 10*val + (c - '0');
f0e67a1d 75 c = lex_peek_unichar(0);
88e1f1a2
JV
76 } while(c >= '0' && c <= '9');
77 push_rpn_item(newSVOP(OP_CONST, 0,
78 newSVuv(val)));
79 } break;
80 case '$': {
81 push_rpn_item(parse_var());
82 } break;
83 case '+': {
84 OP *b = pop_rpn_item();
85 OP *a = pop_rpn_item();
f0e67a1d 86 lex_read_unichar(0);
88e1f1a2
JV
87 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
88 } break;
89 case '-': {
90 OP *b = pop_rpn_item();
91 OP *a = pop_rpn_item();
f0e67a1d 92 lex_read_unichar(0);
88e1f1a2
JV
93 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
94 } break;
95 case '*': {
96 OP *b = pop_rpn_item();
97 OP *a = pop_rpn_item();
f0e67a1d 98 lex_read_unichar(0);
88e1f1a2
JV
99 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
100 } break;
101 case '/': {
102 OP *b = pop_rpn_item();
103 OP *a = pop_rpn_item();
f0e67a1d 104 lex_read_unichar(0);
88e1f1a2
JV
105 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
106 } break;
107 case '%': {
108 OP *b = pop_rpn_item();
109 OP *a = pop_rpn_item();
f0e67a1d 110 lex_read_unichar(0);
88e1f1a2
JV
111 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
112 } break;
113 default: {
394f6a09 114 croak("RPN syntax error");
88e1f1a2
JV
115 } break;
116 }
117 }
118}
119#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
120
121static OP *THX_parse_keyword_rpn(pTHX)
122{
123 OP *op;
f0e67a1d
Z
124 lex_read_space(0);
125 if(lex_peek_unichar(0) != '('/*)*/)
394f6a09 126 croak("RPN expression must be parenthesised");
f0e67a1d 127 lex_read_unichar(0);
88e1f1a2 128 op = parse_rpn_expr();
f0e67a1d 129 if(lex_peek_unichar(0) != /*(*/')')
394f6a09 130 croak("RPN expression must be parenthesised");
f0e67a1d 131 lex_read_unichar(0);
88e1f1a2
JV
132 return op;
133}
134#define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
135
136static OP *THX_parse_keyword_calcrpn(pTHX)
137{
138 OP *varop, *exprop;
f0e67a1d 139 lex_read_space(0);
88e1f1a2 140 varop = parse_var();
f0e67a1d
Z
141 lex_read_space(0);
142 if(lex_peek_unichar(0) != '{'/*}*/)
394f6a09 143 croak("RPN expression must be braced");
f0e67a1d 144 lex_read_unichar(0);
88e1f1a2 145 exprop = parse_rpn_expr();
f0e67a1d 146 if(lex_peek_unichar(0) != /*{*/'}')
394f6a09 147 croak("RPN expression must be braced");
f0e67a1d 148 lex_read_unichar(0);
88e1f1a2
JV
149 return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
150}
151#define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
152
255fdf19
Z
153static OP *THX_parse_keyword_stufftest(pTHX)
154{
155 I32 c;
156 bool do_stuff;
157 lex_read_space(0);
158 do_stuff = lex_peek_unichar(0) == '+';
159 if(do_stuff) {
160 lex_read_unichar(0);
161 lex_read_space(0);
162 }
163 c = lex_peek_unichar(0);
164 if(c == ';') {
165 lex_read_unichar(0);
166 } else if(c != /*{*/'}') {
167 croak("syntax error");
168 }
510966aa 169 if(do_stuff) lex_stuff_pvs(" ", 0);
255fdf19
Z
170 return newOP(OP_NULL, 0);
171}
172#define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
173
88e1f1a2
JV
174/* plugin glue */
175
176static int THX_keyword_active(pTHX_ SV *hintkey_sv)
177{
178 HE *he;
179 if(!GvHV(PL_hintgv)) return 0;
180 he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
181 SvSHARED_HASH(hintkey_sv));
182 return he && SvTRUE(HeVAL(he));
183}
184#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
185
186static void THX_keyword_enable(pTHX_ SV *hintkey_sv)
187{
188 SV *val_sv = newSViv(1);
189 HE *he;
190 PL_hints |= HINT_LOCALIZE_HH;
191 gv_HVadd(PL_hintgv);
192 he = hv_store_ent(GvHV(PL_hintgv),
193 hintkey_sv, val_sv, SvSHARED_HASH(hintkey_sv));
194 if(he) {
195 SV *val = HeVAL(he);
196 SvSETMAGIC(val);
197 } else {
198 SvREFCNT_dec(val_sv);
199 }
200}
201#define keyword_enable(hintkey_sv) THX_keyword_enable(aTHX_ hintkey_sv)
202
203static void THX_keyword_disable(pTHX_ SV *hintkey_sv)
204{
205 if(GvHV(PL_hintgv)) {
206 PL_hints |= HINT_LOCALIZE_HH;
207 hv_delete_ent(GvHV(PL_hintgv),
208 hintkey_sv, G_DISCARD, SvSHARED_HASH(hintkey_sv));
209 }
210}
211#define keyword_disable(hintkey_sv) THX_keyword_disable(aTHX_ hintkey_sv)
212
213static int my_keyword_plugin(pTHX_
214 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
215{
216 if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
217 keyword_active(hintkey_rpn_sv)) {
218 *op_ptr = parse_keyword_rpn();
219 return KEYWORD_PLUGIN_EXPR;
220 } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
221 keyword_active(hintkey_calcrpn_sv)) {
222 *op_ptr = parse_keyword_calcrpn();
223 return KEYWORD_PLUGIN_STMT;
255fdf19
Z
224 } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
225 keyword_active(hintkey_stufftest_sv)) {
226 *op_ptr = parse_keyword_stufftest();
227 return KEYWORD_PLUGIN_STMT;
88e1f1a2
JV
228 } else {
229 return next_keyword_plugin(aTHX_
230 keyword_ptr, keyword_len, op_ptr);
231 }
232}
233
234MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN
235
236BOOT:
237 hintkey_rpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/rpn");
238 hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn");
255fdf19
Z
239 hintkey_stufftest_sv =
240 newSVpvs_share("XS::APItest::KeywordRPN/stufftest");
88e1f1a2
JV
241 next_keyword_plugin = PL_keyword_plugin;
242 PL_keyword_plugin = my_keyword_plugin;
243
244void
58e85f6b 245import(SV *classname, ...)
88e1f1a2
JV
246PREINIT:
247 int i;
248PPCODE:
249 for(i = 1; i != items; i++) {
250 SV *item = ST(i);
251 if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
252 keyword_enable(hintkey_rpn_sv);
253 } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
254 keyword_enable(hintkey_calcrpn_sv);
255fdf19
Z
255 } else if(sv_is_string(item) &&
256 strEQ(SvPVX(item), "stufftest")) {
257 keyword_enable(hintkey_stufftest_sv);
88e1f1a2 258 } else {
394f6a09 259 croak("\"%s\" is not exported by the %s module",
88e1f1a2
JV
260 SvPV_nolen(item), SvPV_nolen(ST(0)));
261 }
262 }
263
264void
58e85f6b 265unimport(SV *classname, ...)
88e1f1a2
JV
266PREINIT:
267 int i;
268PPCODE:
269 for(i = 1; i != items; i++) {
270 SV *item = ST(i);
271 if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
272 keyword_disable(hintkey_rpn_sv);
273 } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
274 keyword_disable(hintkey_calcrpn_sv);
255fdf19
Z
275 } else if(sv_is_string(item) &&
276 strEQ(SvPVX(item), "stufftest")) {
277 keyword_disable(hintkey_stufftest_sv);
88e1f1a2 278 } else {
394f6a09 279 croak("\"%s\" is not exported by the %s module",
88e1f1a2
JV
280 SvPV_nolen(item), SvPV_nolen(ST(0)));
281 }
282 }