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 |
41 | #define WARNINGS_ENABLE(X) |
42 | #endif |
43 | |
44 | |
45 | #include "EXTERN.h" |
46 | #include "perl.h" |
47 | #include "XSUB.h" |
48 | |
49 | #include <string.h> |
50 | |
51 | WARNINGS_ENABLE |
52 | |
53 | #define MY_PKG "Function::Parameters" |
54 | |
55 | #define HINTK_KEYWORDS MY_PKG "/keywords" |
56 | #define HINTK_NAME_ MY_PKG "/name:" |
57 | #define HINTK_SHIFT_ MY_PKG "/shift:" |
58 | |
59 | typedef struct { |
60 | enum { |
61 | FLAG_NAME_OPTIONAL = 1, |
62 | FLAG_NAME_REQUIRED, |
63 | FLAG_NAME_PROHIBITED |
64 | } name; |
65 | char shift[256]; |
66 | } Spec; |
67 | |
68 | static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
69 | |
70 | static int kw_flags(const char *kw_ptr, STRLEN kw_len, Spec *spec) { |
71 | HV *hints; |
72 | SV *sv, **psv; |
73 | const char *p, *kw_active; |
74 | STRLEN kw_active_len; |
75 | |
76 | spec->name = 0; |
77 | spec->shift[0] = '\0'; |
78 | |
79 | if (!(hints = GvHV(PL_hintgv))) { |
80 | return FALSE; |
81 | } |
82 | if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { |
83 | return FALSE; |
84 | } |
85 | sv = *psv; |
86 | kw_active = SvPV(sv, kw_active_len); |
87 | if (kw_active_len <= kw_len) { |
88 | return FALSE; |
89 | } |
90 | for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) { |
91 | if ( |
92 | (p == kw_active || p[-1] == ' ') && |
93 | p[kw_len] == ' ' && |
94 | memcmp(kw_ptr, p, kw_len) == 0 |
95 | ) { |
96 | const char *kf_ptr; |
97 | STRLEN kf_len; |
98 | SV *kf_sv; |
99 | |
100 | kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_)); |
101 | sv_catpvn(kf_sv, kw_ptr, kw_len); |
102 | kf_ptr = SvPV(kf_sv, kf_len); |
103 | if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) { |
104 | croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr); |
105 | } |
106 | spec->name = SvIV(*psv); |
107 | |
108 | kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_)); |
109 | sv_catpvn(kf_sv, kw_ptr, kw_len); |
110 | kf_ptr = SvPV(kf_sv, kf_len); |
111 | if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) { |
112 | croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr); |
113 | } |
114 | my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*psv)); |
115 | |
116 | return TRUE; |
117 | } |
118 | } |
119 | return FALSE; |
120 | } |
121 | |
122 | |
123 | #include "toke_on_crack.c.inc" |
124 | |
125 | |
126 | static int parse_fun(OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) { |
127 | SV *gen, *declarator, *params, *sv; |
128 | line_t line_start; |
129 | int saw_name, saw_colon; |
130 | STRLEN len; |
131 | char *s; |
132 | I32 c; |
133 | |
134 | gen = sv_2mortal(newSVpvs("sub")); |
135 | declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); |
136 | params = sv_2mortal(newSVpvs("")); |
137 | |
138 | line_start = CopLINE(PL_curcop); |
139 | lex_read_space(0); |
140 | |
141 | /* function name */ |
142 | saw_name = 0; |
143 | s = PL_parser->bufptr; |
144 | if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(s, TRUE))) { |
145 | sv_catpvs(gen, " "); |
146 | sv_catpvn(gen, s, len); |
147 | sv_catpvs(declarator, " "); |
148 | sv_catpvn(declarator, s, len); |
149 | lex_read_to(s + len); |
150 | lex_read_space(0); |
151 | saw_name = 1; |
152 | } else if (spec->name == FLAG_NAME_REQUIRED) { |
153 | croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); |
154 | } else { |
155 | sv_catpvs(declarator, " (anon)"); |
156 | } |
157 | |
158 | /* parameters */ |
159 | c = lex_peek_unichar(0); |
160 | if (c == '(') { |
161 | SV *saw_slurpy = NULL; |
162 | |
163 | lex_read_unichar(0); |
164 | lex_read_space(0); |
165 | |
166 | for (;;) { |
167 | c = lex_peek_unichar(0); |
168 | if (c && strchr("$@%", c)) { |
169 | sv_catpvf(params, "%c", (int)c); |
170 | lex_read_unichar(0); |
171 | lex_read_space(0); |
172 | |
173 | s = PL_parser->bufptr; |
174 | if (!(len = S_scan_word(s, FALSE))) { |
175 | croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator)); |
176 | } |
177 | if (saw_slurpy) { |
178 | croak("In %.*s: I was expecting \")\" after \"%s\", not \"%c%.*s\"", (int)SvCUR(declarator), SvPV_nolen(declarator), SvPV_nolen(saw_slurpy), (int)c, (int)len, s); |
179 | } |
180 | if (c != '$') { |
181 | saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s)); |
182 | } |
183 | sv_catpvn(params, s, len); |
184 | sv_catpvs(params, ","); |
185 | lex_read_to(s + len); |
186 | lex_read_space(0); |
187 | |
188 | c = lex_peek_unichar(0); |
189 | if (c == ',') { |
190 | lex_read_unichar(0); |
191 | lex_read_space(0); |
192 | continue; |
193 | } |
194 | } |
195 | |
196 | if (c == ')') { |
197 | lex_read_unichar(0); |
198 | lex_read_space(0); |
199 | break; |
200 | } |
201 | |
202 | if (c == -1) { |
203 | croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator)); |
204 | } |
205 | croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c); |
206 | } |
207 | } |
208 | |
209 | /* prototype */ |
210 | saw_colon = 0; |
211 | c = lex_peek_unichar(0); |
212 | if (c == ':') { |
213 | lex_read_unichar(0); |
214 | lex_read_space(0); |
215 | |
216 | c = lex_peek_unichar(0); |
217 | if (c != '(') { |
218 | saw_colon = 1; |
219 | } else { |
220 | sv = sv_2mortal(newSVpvs("")); |
221 | if (!S_scan_str(sv, TRUE, TRUE)) { |
222 | croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator)); |
223 | } |
224 | sv_catsv(gen, sv); |
225 | lex_read_space(0); |
226 | } |
227 | } |
228 | |
229 | if (saw_name) { |
230 | len = SvCUR(gen); |
231 | s = SvGROW(gen, (len + 1) * 2); |
232 | sv_catpvs(gen, ";"); |
233 | sv_catpvn(gen, s, len); |
234 | } |
235 | |
236 | /* attributes */ |
237 | if (!saw_colon) { |
238 | c = lex_peek_unichar(0); |
239 | if (c == ':') { |
240 | saw_colon = 1; |
241 | lex_read_unichar(0); |
242 | lex_read_space(0); |
243 | } |
244 | } |
245 | if (saw_colon) { |
246 | for (;;) { |
247 | s = PL_parser->bufptr; |
248 | if (!(len = S_scan_word(s, FALSE))) { |
249 | break; |
250 | } |
251 | sv_catpvs(gen, ":"); |
252 | sv_catpvn(gen, s, len); |
253 | lex_read_to(s + len); |
254 | lex_read_space(0); |
255 | c = lex_peek_unichar(0); |
256 | if (c == '(') { |
257 | sv = sv_2mortal(newSVpvs("")); |
258 | if (!S_scan_str(sv, TRUE, TRUE)) { |
259 | croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator)); |
260 | } |
261 | sv_catsv(gen, sv); |
262 | lex_read_space(0); |
263 | c = lex_peek_unichar(0); |
264 | } |
265 | if (c == ':') { |
266 | lex_read_unichar(0); |
267 | lex_read_space(0); |
268 | } |
269 | } |
270 | } |
271 | |
272 | /* body */ |
273 | c = lex_peek_unichar(0); |
274 | if (c != '{') { |
275 | croak("In %.*s: I was expecting a function body, not \"%c\"", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c); |
276 | } |
277 | lex_read_unichar(0); |
278 | sv_catpvs(gen, "{"); |
279 | if (spec->shift[0]) { |
280 | sv_catpvf(gen, "my%s=shift;", spec->shift); |
281 | } |
282 | if (SvCUR(params)) { |
283 | sv_catpvs(gen, "my("); |
284 | sv_catsv(gen, params); |
285 | sv_catpvs(gen, ")=@_;"); |
286 | } |
287 | |
288 | /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ |
289 | |
290 | /* named sub */ |
291 | if (saw_name) { |
292 | lex_stuff_sv(gen, SvUTF8(gen)); |
293 | *pop = parse_barestmt(0); |
294 | return KEYWORD_PLUGIN_STMT; |
295 | } |
296 | |
297 | /* anon sub */ |
298 | sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}"); |
299 | lex_stuff_sv(gen, SvUTF8(gen)); |
300 | *pop = parse_arithexpr(0); |
301 | s = PL_parser->bufptr; |
302 | if (*s != '}') { |
303 | croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s); |
304 | } |
305 | lex_unstuff(s + 1); |
306 | return KEYWORD_PLUGIN_EXPR; |
307 | } |
308 | |
309 | static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
310 | Spec spec; |
311 | int ret; |
312 | |
313 | SAVETMPS; |
314 | |
315 | if (kw_flags(keyword_ptr, keyword_len, &spec)) { |
316 | ret = parse_fun(op_ptr, keyword_ptr, keyword_len, &spec); |
317 | } else { |
318 | ret = next_keyword_plugin(keyword_ptr, keyword_len, op_ptr); |
319 | } |
320 | |
321 | FREETMPS; |
322 | |
323 | return ret; |
324 | } |
325 | |
326 | WARNINGS_RESET |
327 | |
328 | MODULE = Function::Parameters PACKAGE = Function::Parameters |
329 | PROTOTYPES: ENABLE |
330 | |
331 | BOOT: |
332 | WARNINGS_ENABLE { |
333 | HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
334 | newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL)); |
335 | newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED)); |
336 | newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED)); |
337 | newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
338 | newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_)); |
339 | newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); |
340 | newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift)); |
341 | next_keyword_plugin = PL_keyword_plugin; |
342 | PL_keyword_plugin = my_keyword_plugin; |
343 | } WARNINGS_RESET |
344 | |
345 | void |
346 | xs_fini() |
347 | CODE: |
348 | lex_stuff_pvn("}", 1, 0); |