[p5sagit/Function-Parameters.git] / Parameters.xs

/*
Copyright 2012 Lukas Mai.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.
 */

#ifdef __GNUC__
 #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
  #define PRAGMA_GCC_(X) _Pragma(#X)
  #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
 #endif
#endif

#ifndef PRAGMA_GCC
 #define PRAGMA_GCC(X)
#endif

#ifdef DEVEL
 #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
 #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X)
 #define WARNINGS_ENABLE \
 	WARNINGS_ENABLEW(-Wall) \
 	WARNINGS_ENABLEW(-Wextra) \
 	WARNINGS_ENABLEW(-Wundef) \
 	WARNINGS_ENABLEW(-Wshadow) \
 	WARNINGS_ENABLEW(-Wbad-function-cast) \
 	WARNINGS_ENABLEW(-Wcast-align) \
 	WARNINGS_ENABLEW(-Wwrite-strings) \
 	/* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \
 	WARNINGS_ENABLEW(-Wstrict-prototypes) \
 	WARNINGS_ENABLEW(-Wmissing-prototypes) \
 	WARNINGS_ENABLEW(-Winline) \
 	WARNINGS_ENABLEW(-Wdisabled-optimization)

#else
 #define WARNINGS_RESET
 #define WARNINGS_ENABLE
#endif


#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <string.h>

WARNINGS_ENABLE

#define MY_PKG "Function::Parameters"

#define HINTK_KEYWORDS MY_PKG "/keywords"
#define HINTK_NAME_    MY_PKG "/name:"
#define HINTK_SHIFT_   MY_PKG "/shift:"
#define HINTK_ATTRS_   MY_PKG "/attrs:"

#define HAVE_PERL_VERSION(R, V, S) \
	(PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))

typedef struct {
	enum {
		FLAG_NAME_OPTIONAL = 1,
		FLAG_NAME_REQUIRED,
		FLAG_NAME_PROHIBITED
	} name;
	SV *shift;
	SV *attrs;
} Spec;

static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);

static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
	HV *hints;
	SV *sv, **psv;
	const char *p, *kw_active;
	STRLEN kw_active_len;

	spec->name = 0;
	spec->shift = sv_2mortal(newSVpvs(""));
	spec->attrs = sv_2mortal(newSVpvs(""));

	if (!(hints = GvHV(PL_hintgv))) {
		return FALSE;
	}
	if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
		return FALSE;
	}
	sv = *psv;
	kw_active = SvPV(sv, kw_active_len);
	if (kw_active_len <= kw_len) {
		return FALSE;
	}
	for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) {
		if (
			(p == kw_active || p[-1] == ' ') &&
			p[kw_len] == ' ' &&
			memcmp(kw_ptr, p, kw_len) == 0
		) {

#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) do { \
	const char *fk_ptr_; \
	STRLEN fk_len_; \
	SV *fk_sv_; \
	fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \
	sv_catpvn(fk_sv_, PTR, LEN); \
	fk_ptr_ = SvPV(fk_sv_, fk_len_); \
	if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
		croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
	} \
} while (0)

			FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
			spec->name = SvIV(*psv);

			FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
			SvSetSV(spec->shift, *psv);

			FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
			SvSetSV(spec->attrs, *psv);

#undef FETCH_HINTK_INTO
			return TRUE;
		}
	}
	return FALSE;
}


#include "toke_on_crack.c.inc"


static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
	SV *gen, *declarator, *params, *sv;
	line_t line_start;
	int saw_name, saw_colon;
	STRLEN len;
	char *s;
	I32 c;

	gen = sv_2mortal(newSVpvs("sub"));
	declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
	params = sv_2mortal(newSVpvs(""));

	line_start = CopLINE(PL_curcop);
	lex_read_space(0);

	/* function name */
	saw_name = 0;
	s = PL_parser->bufptr;
	if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
		sv_catpvs(gen, " ");
		sv_catpvn(gen, s, len);
		sv_catpvs(declarator, " ");
		sv_catpvn(declarator, s, len);
		lex_read_to(s + len);
		lex_read_space(0);
		saw_name = 1;
	} else if (spec->name == FLAG_NAME_REQUIRED) {
		croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
	} else {
		sv_catpvs(declarator, " (anon)");
	}

	/* parameters */
	c = lex_peek_unichar(0);
	if (c == '(') {
		SV *saw_slurpy = NULL;

		lex_read_unichar(0);
		lex_read_space(0);

		for (;;) {
			c = lex_peek_unichar(0);
			if (c && strchr("$@%", c)) {
				sv_catpvf(params, "%c", (int)c);
				lex_read_unichar(0);
				lex_read_space(0);

				s = PL_parser->bufptr;
				if (!(len = S_scan_word(aTHX_ s, FALSE))) {
					croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator));
				}
				if (saw_slurpy) {
					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);
				}
				if (c != '$') {
					saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
				}
				sv_catpvn(params, s, len);
				sv_catpvs(params, ",");
				lex_read_to(s + len);
				lex_read_space(0);

				c = lex_peek_unichar(0);
				if (c == ',') {
					lex_read_unichar(0);
					lex_read_space(0);
					continue;
				}
			}

			if (c == ')') {
				lex_read_unichar(0);
				lex_read_space(0);
				break;
			}

			if (c == -1) {
				croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator));
			}
			croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
		}
	}

	/* prototype */
	saw_colon = 0;
	c = lex_peek_unichar(0);
	if (c == ':') {
		lex_read_unichar(0);
		lex_read_space(0);

		c = lex_peek_unichar(0);
		if (c != '(') {
			saw_colon = 1;
		} else {
			sv = sv_2mortal(newSVpvs(""));
			if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
				croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator));
			}
			sv_catsv(gen, sv);
			lex_read_space(0);
		}
	}

	if (saw_name) {
		len = SvCUR(gen);
		s = SvGROW(gen, (len + 1) * 2);
		sv_catpvs(gen, ";");
		sv_catpvn(gen, s, len);
	}

	/* attributes */
	if (SvTRUE(spec->attrs)) {
		sv_catsv(gen, spec->attrs);
	}

	if (!saw_colon) {
		c = lex_peek_unichar(0);
		if (c == ':') {
			saw_colon = 1;
			lex_read_unichar(0);
			lex_read_space(0);
		}
	}
	if (saw_colon) {
		for (;;) {
			s = PL_parser->bufptr;
			if (!(len = S_scan_word(aTHX_ s, FALSE))) {
				break;
			}
			sv_catpvs(gen, ":");
			sv_catpvn(gen, s, len);
			lex_read_to(s + len);
			lex_read_space(0);
			c = lex_peek_unichar(0);
			if (c == '(') {
				sv = sv_2mortal(newSVpvs(""));
				if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
					croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator));
				}
				sv_catsv(gen, sv);
				lex_read_space(0);
				c = lex_peek_unichar(0);
			}
			if (c == ':') {
				lex_read_unichar(0);
				lex_read_space(0);
			}
		}
	}

	/* body */
	c = lex_peek_unichar(0);
	if (c != '{') {
		croak("In %.*s: I was expecting a function body, not \"%c\"", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
	}
	lex_read_unichar(0);
	sv_catpvs(gen, "{");
	if (SvTRUE(spec->shift)) {
		sv_catpvs(gen, "my");
		sv_catsv(gen, spec->shift);
		sv_catpvs(gen, "=shift;");
	}
	if (SvCUR(params)) {
		sv_catpvs(gen, "my(");
		sv_catsv(gen, params);
		sv_catpvs(gen, ")=@_;");
	}


	/* named sub */
	if (saw_name) {
		/* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
		lex_stuff_sv(gen, SvUTF8(gen));
		*pop = parse_barestmt(0);
		return KEYWORD_PLUGIN_STMT;
	}

	/* anon sub */
	sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
	/* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
	lex_stuff_sv(gen, SvUTF8(gen));
	*pop = parse_arithexpr(0);
	s = PL_parser->bufptr;
	if (*s != '}') {
		croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
	}
	lex_unstuff(s + 1);
	/* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
	return KEYWORD_PLUGIN_EXPR;
}

static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
	Spec spec;
	int ret;

	SAVETMPS;

	if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
		ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
	} else {
		ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
	}

	FREETMPS;

	return ret;
}

static int magic_free(pTHX_ SV *sv, MAGIC *mg) {
	lex_stuff_pvn("}", 1, 0);
	/* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
	return 0;
}

static int magic_nop(pTHX_ SV *sv, MAGIC *mg) {
	return 0;
}

static MGVTBL my_vtbl = {
	0,           /* get   */
	0,           /* set   */
	0,           /* len   */
	0,           /* clear */
	magic_free,  /* free  */
	0,           /* copy  */
	0,           /* dup   */
	magic_nop    /* local */
};

WARNINGS_RESET

MODULE = Function::Parameters   PACKAGE = Function::Parameters
PROTOTYPES: ENABLE

BOOT:
WARNINGS_ENABLE {
	HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
	newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
	newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
	newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
	newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
	newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
	newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
	newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
	newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
	next_keyword_plugin = PL_keyword_plugin;
	PL_keyword_plugin = my_keyword_plugin;
} WARNINGS_RESET

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