2 Copyright 2012 Lukas Mai.
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.
8 See http://dev.perl.org/licenses/ for more information.
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)
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)
40 #define WARNINGS_RESET
41 #define WARNINGS_ENABLE
45 #define PERL_NO_GET_CONTEXT
54 #define MY_PKG "Function::Parameters"
56 #define HINTK_KEYWORDS MY_PKG "/keywords"
57 #define HINTK_NAME_ MY_PKG "/name:"
58 #define HINTK_SHIFT_ MY_PKG "/shift:"
60 #define HAVE_PERL_VERSION(R, V, S) \
61 (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
65 FLAG_NAME_OPTIONAL = 1,
72 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
74 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
77 const char *p, *kw_active;
81 spec->shift[0] = '\0';
83 if (!(hints = GvHV(PL_hintgv))) {
86 if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
90 kw_active = SvPV(sv, kw_active_len);
91 if (kw_active_len <= kw_len) {
94 for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) {
96 (p == kw_active || p[-1] == ' ') &&
98 memcmp(kw_ptr, p, kw_len) == 0
104 kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_));
105 sv_catpvn(kf_sv, kw_ptr, kw_len);
106 kf_ptr = SvPV(kf_sv, kf_len);
107 if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
108 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
110 spec->name = SvIV(*psv);
112 kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_));
113 sv_catpvn(kf_sv, kw_ptr, kw_len);
114 kf_ptr = SvPV(kf_sv, kf_len);
115 if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
116 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
118 my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*psv));
127 #include "toke_on_crack.c.inc"
130 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
131 SV *gen, *declarator, *params, *sv;
133 int saw_name, saw_colon;
138 gen = sv_2mortal(newSVpvs("sub"));
139 declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
140 params = sv_2mortal(newSVpvs(""));
142 line_start = CopLINE(PL_curcop);
147 s = PL_parser->bufptr;
148 if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
150 sv_catpvn(gen, s, len);
151 sv_catpvs(declarator, " ");
152 sv_catpvn(declarator, s, len);
153 lex_read_to(s + len);
156 } else if (spec->name == FLAG_NAME_REQUIRED) {
157 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
159 sv_catpvs(declarator, " (anon)");
163 c = lex_peek_unichar(0);
165 SV *saw_slurpy = NULL;
171 c = lex_peek_unichar(0);
172 if (c && strchr("$@%", c)) {
173 sv_catpvf(params, "%c", (int)c);
177 s = PL_parser->bufptr;
178 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
179 croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator));
182 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);
185 saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
187 sv_catpvn(params, s, len);
188 sv_catpvs(params, ",");
189 lex_read_to(s + len);
192 c = lex_peek_unichar(0);
207 croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator));
209 croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
215 c = lex_peek_unichar(0);
220 c = lex_peek_unichar(0);
224 sv = sv_2mortal(newSVpvs(""));
225 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
226 croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator));
235 s = SvGROW(gen, (len + 1) * 2);
237 sv_catpvn(gen, s, len);
242 c = lex_peek_unichar(0);
251 s = PL_parser->bufptr;
252 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
256 sv_catpvn(gen, s, len);
257 lex_read_to(s + len);
259 c = lex_peek_unichar(0);
261 sv = sv_2mortal(newSVpvs(""));
262 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
263 croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator));
267 c = lex_peek_unichar(0);
277 c = lex_peek_unichar(0);
279 croak("In %.*s: I was expecting a function body, not \"%c\"", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
283 if (spec->shift[0]) {
284 sv_catpvf(gen, "my%s=shift;", spec->shift);
287 sv_catpvs(gen, "my(");
288 sv_catsv(gen, params);
289 sv_catpvs(gen, ")=@_;");
292 /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
296 lex_stuff_sv(gen, SvUTF8(gen));
297 *pop = parse_barestmt(0);
298 return KEYWORD_PLUGIN_STMT;
302 sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
303 lex_stuff_sv(gen, SvUTF8(gen));
304 *pop = parse_arithexpr(0);
305 s = PL_parser->bufptr;
307 croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
310 return KEYWORD_PLUGIN_EXPR;
313 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
319 if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
320 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
322 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
332 MODULE = Function::Parameters PACKAGE = Function::Parameters
337 HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
338 newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
339 newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
340 newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
341 newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
342 newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
343 newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
344 newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
345 next_keyword_plugin = PL_keyword_plugin;
346 PL_keyword_plugin = my_keyword_plugin;
352 lex_stuff_pvn("}", 1, 0);