#endif
+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#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_REQUIRED,
FLAG_NAME_PROHIBITED
} name;
- char shift[256];
+ SV *shift;
+ SV *attrs;
} Spec;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
-static int kw_flags(const char *kw_ptr, STRLEN kw_len, Spec *spec) {
+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[0] = '\0';
+ spec->shift = sv_2mortal(newSVpvs(""));
+ spec->attrs = sv_2mortal(newSVpvs(""));
if (!(hints = GvHV(PL_hintgv))) {
return FALSE;
if (kw_active_len <= kw_len) {
return FALSE;
}
- for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) {
+ 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
) {
- const char *kf_ptr;
- STRLEN kf_len;
- SV *kf_sv;
-
- kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_));
- sv_catpvn(kf_sv, kw_ptr, kw_len);
- kf_ptr = SvPV(kf_sv, kf_len);
- if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
- croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
- }
+
+#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);
- kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_));
- sv_catpvn(kf_sv, kw_ptr, kw_len);
- kf_ptr = SvPV(kf_sv, kf_len);
- if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
- croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
- }
- my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*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;
}
}
#include "toke_on_crack.c.inc"
-static int parse_fun(OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
+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;
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(s, TRUE))) {
+ if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
sv_catpvs(gen, " ");
sv_catpvn(gen, s, len);
sv_catpvs(declarator, " ");
for (;;) {
c = lex_peek_unichar(0);
- if (c && strchr("$@%", c)) {
+ 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(s, FALSE))) {
- croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ if (!(len = S_scan_word(aTHX_ s, FALSE))) {
+ croak("In %"SVf": missing identifier", SVfARG(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);
+ 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));
}
if (c == -1) {
- croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
}
- croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
+ croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
}
}
saw_colon = 1;
} else {
sv = sv_2mortal(newSVpvs(""));
- if (!S_scan_str(sv, TRUE, TRUE)) {
- croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
+ croak("In %"SVf": prototype not terminated", SVfARG(declarator));
}
sv_catsv(gen, sv);
lex_read_space(0);
}
/* attributes */
+ if (SvTRUE(spec->attrs)) {
+ sv_catsv(gen, spec->attrs);
+ }
+
if (!saw_colon) {
c = lex_peek_unichar(0);
if (c == ':') {
if (saw_colon) {
for (;;) {
s = PL_parser->bufptr;
- if (!(len = S_scan_word(s, FALSE))) {
+ if (!(len = S_scan_word(aTHX_ s, FALSE))) {
break;
}
sv_catpvs(gen, ":");
c = lex_peek_unichar(0);
if (c == '(') {
sv = sv_2mortal(newSVpvs(""));
- if (!S_scan_str(sv, TRUE, TRUE)) {
- croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator));
+ 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);
/* 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);
+ croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
}
lex_read_unichar(0);
sv_catpvs(gen, "{");
- if (spec->shift[0]) {
- sv_catpvf(gen, "my%s=shift;", spec->shift);
+ 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_catpvs(gen, ")=@_;");
}
- /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
-
/* 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;
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;
}
SAVETMPS;
- if (kw_flags(keyword_ptr, keyword_len, &spec)) {
- ret = parse_fun(op_ptr, keyword_ptr, keyword_len, &spec);
+ 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(keyword_ptr, keyword_len, op_ptr);
+ 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
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, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
+ newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
+ /**/
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
} WARNINGS_RESET
void
-xs_fini()
+_fini()
CODE:
- lex_stuff_pvn("}", 1, 0);
+ sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0);
projects / p5sagit/Function-Parameters.git / blobdiff