This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement facility to plug in syntax triggered by keywords
[perl5.git] / ext / XS-APItest-KeywordRPN / KeywordRPN.xs
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
12 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv;
13 static 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
20 static 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
30 static 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
39 static 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
55 static 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
85 static 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
153 static 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
168 static 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
187 static 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
197 static 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
214 static 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
224 static 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
241 MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN
242
243 BOOT:
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
249 void
250 import(SV *class, ...)
251 PREINIT:
252         int i;
253 PPCODE:
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
267 void
268 unimport(SV *class, ...)
269 PREINIT:
270         int i;
271 PPCODE:
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         }