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