[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))))))

#if HAVE_PERL_VERSION(5, 16, 0)
 #define IF_HAVE_PERL_5_16(YES, NO) YES
#else
 #define IF_HAVE_PERL_5_16(YES, NO) NO
#endif

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 = strchr(p, *kw_ptr)) &&
		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) STMT_START { \
	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_); \
	} \
} STMT_END

			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;
	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(""));

	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 == '$' || c == '@' || 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 %"SVf": missing identifier", SVfARG(declarator));
				}
				if (saw_slurpy) {
					croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%c%.*s\"", SVfARG(declarator), SVfARG(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 %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
			}
			croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(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 %"SVf": prototype not terminated", SVfARG(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 %"SVf": unterminated attribute parameter in attribute list", SVfARG(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 %"SVf": I was expecting a function body, not \"%c\"", SVfARG(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_));
	/**/
	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
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;
b72eb6ee	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(""));
b72eb6ee	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
b72eb6ee	127	FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
db81d362	128	spec->name = SvIV(*psv);
db81d362	129
b72eb6ee	130	FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
b72eb6ee	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	}
db81d362	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 */
db81d362	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)) {
7dd35535	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) {
f9516672	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);