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:"
59 #define HINTK_ATTRS_ MY_PKG "/attrs:"
61 #define HAVE_PERL_VERSION(R, V, S) \
62 (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
64 #if HAVE_PERL_VERSION(5, 16, 0)
65 #define IF_HAVE_PERL_5_16(YES, NO) YES
67 #define IF_HAVE_PERL_5_16(YES, NO) NO
72 FLAG_NAME_OPTIONAL = 1,
80 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
82 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
85 const char *p, *kw_active;
89 spec->shift = sv_2mortal(newSVpvs(""));
90 spec->attrs = sv_2mortal(newSVpvs(""));
92 if (!(hints = GvHV(PL_hintgv))) {
95 if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
99 kw_active = SvPV(sv, kw_active_len);
100 if (kw_active_len <= kw_len) {
105 (p = strchr(p, *kw_ptr)) &&
106 p < kw_active + kw_active_len - kw_len;
110 (p == kw_active || p[-1] == ' ') &&
112 memcmp(kw_ptr, p, kw_len) == 0
115 #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
116 const char *fk_ptr_; \
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_); \
127 FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
128 spec->name = SvIV(*psv);
130 FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
131 SvSetSV(spec->shift, *psv);
133 FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
134 SvSetSV(spec->attrs, *psv);
136 #undef FETCH_HINTK_INTO
144 #include "toke_on_crack.c.inc"
147 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
148 SV *gen, *declarator, *params, *sv;
149 int saw_name, saw_colon;
154 gen = sv_2mortal(newSVpvs("sub"));
155 declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
156 params = sv_2mortal(newSVpvs(""));
162 s = PL_parser->bufptr;
163 if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
165 sv_catpvn(gen, s, len);
166 sv_catpvs(declarator, " ");
167 sv_catpvn(declarator, s, len);
168 lex_read_to(s + len);
171 } else if (spec->name == FLAG_NAME_REQUIRED) {
172 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
174 sv_catpvs(declarator, " (anon)");
178 c = lex_peek_unichar(0);
180 SV *saw_slurpy = NULL;
186 c = lex_peek_unichar(0);
187 if (c == '$' || c == '@' || c == '%') {
188 sv_catpvf(params, "%c", (int)c);
192 s = PL_parser->bufptr;
193 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
194 croak("In %"SVf": missing identifier", SVfARG(declarator));
197 croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%c%.*s\"", SVfARG(declarator), SVfARG(saw_slurpy), (int)c, (int)len, s);
200 saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
202 sv_catpvn(params, s, len);
203 sv_catpvs(params, ",");
204 lex_read_to(s + len);
207 c = lex_peek_unichar(0);
222 croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
224 croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
230 c = lex_peek_unichar(0);
235 c = lex_peek_unichar(0);
239 sv = sv_2mortal(newSVpvs(""));
240 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
241 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
250 s = SvGROW(gen, (len + 1) * 2);
252 sv_catpvn(gen, s, len);
256 if (SvTRUE(spec->attrs)) {
257 sv_catsv(gen, spec->attrs);
261 c = lex_peek_unichar(0);
270 s = PL_parser->bufptr;
271 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
275 sv_catpvn(gen, s, len);
276 lex_read_to(s + len);
278 c = lex_peek_unichar(0);
280 sv = sv_2mortal(newSVpvs(""));
281 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
282 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
286 c = lex_peek_unichar(0);
296 c = lex_peek_unichar(0);
298 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
302 if (SvTRUE(spec->shift)) {
303 sv_catpvs(gen, "my");
304 sv_catsv(gen, spec->shift);
305 sv_catpvs(gen, "=shift;");
308 sv_catpvs(gen, "my(");
309 sv_catsv(gen, params);
310 sv_catpvs(gen, ")=@_;");
315 /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
316 lex_stuff_sv(gen, SvUTF8(gen));
317 *pop = parse_barestmt(0);
318 return KEYWORD_PLUGIN_STMT;
322 sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
323 /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
324 lex_stuff_sv(gen, SvUTF8(gen));
325 *pop = parse_arithexpr(0);
326 s = PL_parser->bufptr;
328 croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
331 /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
332 return KEYWORD_PLUGIN_EXPR;
335 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
341 if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
342 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
344 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
352 static int magic_free(pTHX_ SV *sv, MAGIC *mg) {
353 lex_stuff_pvn("}", 1, 0);
354 /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
358 static int magic_nop(pTHX_ SV *sv, MAGIC *mg) {
362 static MGVTBL my_vtbl = {
367 magic_free, /* free */
370 magic_nop /* local */
375 MODULE = Function::Parameters PACKAGE = Function::Parameters
380 HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
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_));
388 newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
390 next_keyword_plugin = PL_keyword_plugin;
391 PL_keyword_plugin = my_keyword_plugin;
397 sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0);