Commit | Line | Data |
db81d362 |
1 | /* |
2 | Copyright 2012 Lukas Mai. |
3 | |
4 | This program is free software; you can redistribute it and/or modify it |
5 | under the terms of either: the GNU General Public License as published |
6 | by the Free Software Foundation; or the Artistic License. |
7 | |
8 | See http://dev.perl.org/licenses/ for more information. |
9 | */ |
10 | |
11 | #ifdef __GNUC__ |
12 | #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5 |
13 | #define PRAGMA_GCC_(X) _Pragma(#X) |
14 | #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X) |
15 | #endif |
16 | #endif |
17 | |
18 | #ifndef PRAGMA_GCC |
19 | #define PRAGMA_GCC(X) |
20 | #endif |
21 | |
22 | #ifdef DEVEL |
23 | #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop) |
24 | #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X) |
25 | #define WARNINGS_ENABLE \ |
26 | WARNINGS_ENABLEW(-Wall) \ |
27 | WARNINGS_ENABLEW(-Wextra) \ |
28 | WARNINGS_ENABLEW(-Wundef) \ |
29 | WARNINGS_ENABLEW(-Wshadow) \ |
30 | WARNINGS_ENABLEW(-Wbad-function-cast) \ |
31 | WARNINGS_ENABLEW(-Wcast-align) \ |
32 | WARNINGS_ENABLEW(-Wwrite-strings) \ |
33 | /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \ |
34 | WARNINGS_ENABLEW(-Wstrict-prototypes) \ |
35 | WARNINGS_ENABLEW(-Wmissing-prototypes) \ |
36 | WARNINGS_ENABLEW(-Winline) \ |
37 | WARNINGS_ENABLEW(-Wdisabled-optimization) |
38 | |
39 | #else |
40 | #define WARNINGS_RESET |
1bc47886 |
41 | #define WARNINGS_ENABLE |
db81d362 |
42 | #endif |
43 | |
44 | |
7dd35535 |
45 | #define PERL_NO_GET_CONTEXT |
db81d362 |
46 | #include "EXTERN.h" |
47 | #include "perl.h" |
48 | #include "XSUB.h" |
49 | |
50 | #include <string.h> |
51 | |
52 | WARNINGS_ENABLE |
53 | |
54 | #define MY_PKG "Function::Parameters" |
55 | |
56 | #define HINTK_KEYWORDS MY_PKG "/keywords" |
57 | #define HINTK_NAME_ MY_PKG "/name:" |
58 | #define HINTK_SHIFT_ MY_PKG "/shift:" |
b72eb6ee |
59 | #define HINTK_ATTRS_ MY_PKG "/attrs:" |
db81d362 |
60 | |
7dd35535 |
61 | #define HAVE_PERL_VERSION(R, V, S) \ |
62 | (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) |
63 | |
de013990 |
64 | #if HAVE_PERL_VERSION(5, 16, 0) |
65 | #define IF_HAVE_PERL_5_16(YES, NO) YES |
66 | #else |
67 | #define IF_HAVE_PERL_5_16(YES, NO) NO |
68 | #endif |
69 | |
db81d362 |
70 | typedef struct { |
71 | enum { |
72 | FLAG_NAME_OPTIONAL = 1, |
73 | FLAG_NAME_REQUIRED, |
74 | FLAG_NAME_PROHIBITED |
75 | } name; |
b72eb6ee |
76 | SV *shift; |
77 | SV *attrs; |
db81d362 |
78 | } Spec; |
79 | |
80 | static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
81 | |
7dd35535 |
82 | static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) { |
db81d362 |
83 | HV *hints; |
84 | SV *sv, **psv; |
85 | const char *p, *kw_active; |
86 | STRLEN kw_active_len; |
87 | |
88 | spec->name = 0; |
b72eb6ee |
89 | spec->shift = sv_2mortal(newSVpvs("")); |
90 | spec->attrs = sv_2mortal(newSVpvs("")); |
db81d362 |
91 | |
92 | if (!(hints = GvHV(PL_hintgv))) { |
93 | return FALSE; |
94 | } |
95 | if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { |
96 | return FALSE; |
97 | } |
98 | sv = *psv; |
99 | kw_active = SvPV(sv, kw_active_len); |
100 | if (kw_active_len <= kw_len) { |
101 | return FALSE; |
102 | } |
e88490f6 |
103 | for ( |
104 | p = kw_active; |
105 | (p = strchr(p, *kw_ptr)) && |
106 | p < kw_active + kw_active_len - kw_len; |
107 | p++ |
108 | ) { |
db81d362 |
109 | if ( |
110 | (p == kw_active || p[-1] == ' ') && |
111 | p[kw_len] == ' ' && |
112 | memcmp(kw_ptr, p, kw_len) == 0 |
113 | ) { |
b72eb6ee |
114 | |
d970c3e7 |
115 | #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \ |
b72eb6ee |
116 | const char *fk_ptr_; \ |
117 | STRLEN fk_len_; \ |
118 | SV *fk_sv_; \ |
119 | fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \ |
120 | sv_catpvn(fk_sv_, PTR, LEN); \ |
121 | fk_ptr_ = SvPV(fk_sv_, fk_len_); \ |
122 | if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \ |
123 | croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \ |
124 | } \ |
d970c3e7 |
125 | } STMT_END |
b72eb6ee |
126 | |
127 | FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv); |
db81d362 |
128 | spec->name = SvIV(*psv); |
129 | |
b72eb6ee |
130 | FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv); |
131 | SvSetSV(spec->shift, *psv); |
db81d362 |
132 | |
b72eb6ee |
133 | FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv); |
134 | SvSetSV(spec->attrs, *psv); |
135 | |
136 | #undef FETCH_HINTK_INTO |
db81d362 |
137 | return TRUE; |
138 | } |
139 | } |
140 | return FALSE; |
141 | } |
142 | |
143 | |
144 | #include "toke_on_crack.c.inc" |
145 | |
146 | |
7dd35535 |
147 | static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) { |
db81d362 |
148 | SV *gen, *declarator, *params, *sv; |
db81d362 |
149 | int saw_name, saw_colon; |
150 | STRLEN len; |
151 | char *s; |
152 | I32 c; |
153 | |
154 | gen = sv_2mortal(newSVpvs("sub")); |
155 | declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); |
156 | params = sv_2mortal(newSVpvs("")); |
157 | |
db81d362 |
158 | lex_read_space(0); |
159 | |
160 | /* function name */ |
161 | saw_name = 0; |
162 | s = PL_parser->bufptr; |
7dd35535 |
163 | if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) { |
db81d362 |
164 | sv_catpvs(gen, " "); |
165 | sv_catpvn(gen, s, len); |
166 | sv_catpvs(declarator, " "); |
167 | sv_catpvn(declarator, s, len); |
168 | lex_read_to(s + len); |
169 | lex_read_space(0); |
170 | saw_name = 1; |
171 | } else if (spec->name == FLAG_NAME_REQUIRED) { |
172 | croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); |
173 | } else { |
174 | sv_catpvs(declarator, " (anon)"); |
175 | } |
176 | |
177 | /* parameters */ |
178 | c = lex_peek_unichar(0); |
179 | if (c == '(') { |
180 | SV *saw_slurpy = NULL; |
181 | |
182 | lex_read_unichar(0); |
183 | lex_read_space(0); |
184 | |
185 | for (;;) { |
186 | c = lex_peek_unichar(0); |
f5cc9bdd |
187 | if (c == '$' || c == '@' || c == '%') { |
db81d362 |
188 | sv_catpvf(params, "%c", (int)c); |
189 | lex_read_unichar(0); |
190 | lex_read_space(0); |
191 | |
192 | s = PL_parser->bufptr; |
7dd35535 |
193 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
85bc3fbd |
194 | croak("In %"SVf": missing identifier", SVfARG(declarator)); |
db81d362 |
195 | } |
196 | if (saw_slurpy) { |
85bc3fbd |
197 | croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%c%.*s\"", SVfARG(declarator), SVfARG(saw_slurpy), (int)c, (int)len, s); |
db81d362 |
198 | } |
199 | if (c != '$') { |
200 | saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s)); |
201 | } |
202 | sv_catpvn(params, s, len); |
203 | sv_catpvs(params, ","); |
204 | lex_read_to(s + len); |
205 | lex_read_space(0); |
206 | |
207 | c = lex_peek_unichar(0); |
208 | if (c == ',') { |
209 | lex_read_unichar(0); |
210 | lex_read_space(0); |
211 | continue; |
212 | } |
213 | } |
214 | |
215 | if (c == ')') { |
216 | lex_read_unichar(0); |
217 | lex_read_space(0); |
218 | break; |
219 | } |
220 | |
221 | if (c == -1) { |
85bc3fbd |
222 | croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator)); |
db81d362 |
223 | } |
85bc3fbd |
224 | croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c); |
db81d362 |
225 | } |
226 | } |
227 | |
228 | /* prototype */ |
229 | saw_colon = 0; |
230 | c = lex_peek_unichar(0); |
231 | if (c == ':') { |
232 | lex_read_unichar(0); |
233 | lex_read_space(0); |
234 | |
235 | c = lex_peek_unichar(0); |
236 | if (c != '(') { |
237 | saw_colon = 1; |
238 | } else { |
239 | sv = sv_2mortal(newSVpvs("")); |
7dd35535 |
240 | if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { |
f34187b8 |
241 | croak("In %"SVf": prototype not terminated", SVfARG(declarator)); |
db81d362 |
242 | } |
243 | sv_catsv(gen, sv); |
244 | lex_read_space(0); |
245 | } |
246 | } |
247 | |
248 | if (saw_name) { |
249 | len = SvCUR(gen); |
250 | s = SvGROW(gen, (len + 1) * 2); |
251 | sv_catpvs(gen, ";"); |
252 | sv_catpvn(gen, s, len); |
253 | } |
254 | |
255 | /* attributes */ |
b72eb6ee |
256 | if (SvTRUE(spec->attrs)) { |
257 | sv_catsv(gen, spec->attrs); |
258 | } |
259 | |
db81d362 |
260 | if (!saw_colon) { |
261 | c = lex_peek_unichar(0); |
262 | if (c == ':') { |
263 | saw_colon = 1; |
264 | lex_read_unichar(0); |
265 | lex_read_space(0); |
266 | } |
267 | } |
268 | if (saw_colon) { |
269 | for (;;) { |
270 | s = PL_parser->bufptr; |
7dd35535 |
271 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
db81d362 |
272 | break; |
273 | } |
274 | sv_catpvs(gen, ":"); |
275 | sv_catpvn(gen, s, len); |
276 | lex_read_to(s + len); |
277 | lex_read_space(0); |
278 | c = lex_peek_unichar(0); |
279 | if (c == '(') { |
280 | sv = sv_2mortal(newSVpvs("")); |
7dd35535 |
281 | if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { |
f34187b8 |
282 | croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); |
db81d362 |
283 | } |
284 | sv_catsv(gen, sv); |
285 | lex_read_space(0); |
286 | c = lex_peek_unichar(0); |
287 | } |
288 | if (c == ':') { |
289 | lex_read_unichar(0); |
290 | lex_read_space(0); |
291 | } |
292 | } |
293 | } |
294 | |
295 | /* body */ |
296 | c = lex_peek_unichar(0); |
297 | if (c != '{') { |
85bc3fbd |
298 | croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); |
db81d362 |
299 | } |
300 | lex_read_unichar(0); |
301 | sv_catpvs(gen, "{"); |
b72eb6ee |
302 | if (SvTRUE(spec->shift)) { |
303 | sv_catpvs(gen, "my"); |
304 | sv_catsv(gen, spec->shift); |
305 | sv_catpvs(gen, "=shift;"); |
db81d362 |
306 | } |
307 | if (SvCUR(params)) { |
308 | sv_catpvs(gen, "my("); |
309 | sv_catsv(gen, params); |
310 | sv_catpvs(gen, ")=@_;"); |
311 | } |
312 | |
db81d362 |
313 | /* named sub */ |
314 | if (saw_name) { |
20dbca8f |
315 | /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ |
db81d362 |
316 | lex_stuff_sv(gen, SvUTF8(gen)); |
317 | *pop = parse_barestmt(0); |
318 | return KEYWORD_PLUGIN_STMT; |
319 | } |
320 | |
321 | /* anon sub */ |
322 | sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}"); |
20dbca8f |
323 | /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ |
db81d362 |
324 | lex_stuff_sv(gen, SvUTF8(gen)); |
325 | *pop = parse_arithexpr(0); |
326 | s = PL_parser->bufptr; |
327 | if (*s != '}') { |
328 | croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s); |
329 | } |
330 | lex_unstuff(s + 1); |
20dbca8f |
331 | /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ |
db81d362 |
332 | return KEYWORD_PLUGIN_EXPR; |
333 | } |
334 | |
335 | static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
336 | Spec spec; |
337 | int ret; |
338 | |
339 | SAVETMPS; |
340 | |
7dd35535 |
341 | if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) { |
342 | ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec); |
db81d362 |
343 | } else { |
7dd35535 |
344 | ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); |
db81d362 |
345 | } |
346 | |
347 | FREETMPS; |
348 | |
349 | return ret; |
350 | } |
351 | |
f9516672 |
352 | static int magic_free(pTHX_ SV *sv, MAGIC *mg) { |
353 | lex_stuff_pvn("}", 1, 0); |
832f857d |
354 | /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ |
f9516672 |
355 | return 0; |
356 | } |
357 | |
358 | static int magic_nop(pTHX_ SV *sv, MAGIC *mg) { |
359 | return 0; |
360 | } |
361 | |
362 | static MGVTBL my_vtbl = { |
363 | 0, /* get */ |
364 | 0, /* set */ |
365 | 0, /* len */ |
366 | 0, /* clear */ |
367 | magic_free, /* free */ |
368 | 0, /* copy */ |
369 | 0, /* dup */ |
370 | magic_nop /* local */ |
371 | }; |
372 | |
db81d362 |
373 | WARNINGS_RESET |
374 | |
375 | MODULE = Function::Parameters PACKAGE = Function::Parameters |
376 | PROTOTYPES: ENABLE |
377 | |
378 | BOOT: |
379 | WARNINGS_ENABLE { |
380 | HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
426a4d69 |
381 | /**/ |
db81d362 |
382 | newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL)); |
383 | newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED)); |
384 | newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED)); |
385 | newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
386 | newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_)); |
387 | newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); |
b72eb6ee |
388 | newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); |
426a4d69 |
389 | /**/ |
db81d362 |
390 | next_keyword_plugin = PL_keyword_plugin; |
391 | PL_keyword_plugin = my_keyword_plugin; |
392 | } WARNINGS_RESET |
393 | |
394 | void |
f9516672 |
395 | _fini() |
db81d362 |
396 | CODE: |
f9516672 |
397 | sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0); |