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