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