X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Parameters.xs;h=3cf607b293eec23b6440fe12987441b1b4adb989;hb=45ad1cfe89df94b7c134e4f48f8005a55fab4403;hp=ec46ef337a6eaa6841c0f2709db57f4a0b9e6b5b;hpb=e6d6238331493d5dadfcfbf7231d9dccb80acd20;p=p5sagit%2FFunction-Parameters.git diff --git a/Parameters.xs b/Parameters.xs index ec46ef3..3cf607b 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -85,24 +85,25 @@ WARNINGS_ENABLE #define HINTK_FLAGS_ MY_PKG "/flags:" #define HINTK_SHIFT_ MY_PKG "/shift:" #define HINTK_ATTRS_ MY_PKG "/attrs:" +#define HINTK_REIFY_ MY_PKG "/reify:" #define DEFSTRUCT(T) typedef struct T T; struct T -#define UV_BITS (sizeof (UV) * CHAR_BIT) - enum { - FLAG_NAME_OK = 0x01, - FLAG_ANON_OK = 0x02, - FLAG_DEFAULT_ARGS = 0x04, - FLAG_CHECK_NARGS = 0x08, - FLAG_INVOCANT = 0x10, - FLAG_NAMED_PARAMS = 0x20, - FLAG_TYPES_OK = 0x40, - FLAG_CHECK_TARGS = 0x80 + FLAG_NAME_OK = 0x001, + FLAG_ANON_OK = 0x002, + FLAG_DEFAULT_ARGS = 0x004, + FLAG_CHECK_NARGS = 0x008, + FLAG_INVOCANT = 0x010, + FLAG_NAMED_PARAMS = 0x020, + FLAG_TYPES_OK = 0x040, + FLAG_CHECK_TARGS = 0x080, + FLAG_RUNTIME = 0x100 }; DEFSTRUCT(KWSpec) { unsigned flags; + I32 reify_type; SV *shift; SV *attrs; }; @@ -157,67 +158,6 @@ static SV *sentinel_mortalize(Sentinel sen, SV *sv) { return sv; } -static int kw_flags(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, KWSpec *spec) { - HV *hints; - SV *sv, **psv; - const char *p, *kw_active; - STRLEN kw_active_len; - - spec->flags = 0; - spec->shift = sentinel_mortalize(sen, newSVpvs("")); - spec->attrs = sentinel_mortalize(sen, 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_ = sentinel_mortalize(sen, 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(FLAGS_, kw_ptr, kw_len, psv); - spec->flags = 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; -} - #if HAVE_PERL_VERSION(5, 17, 2) #define MY_OP_SLABBED(O) ((O)->op_slabbed) @@ -558,20 +498,33 @@ static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator) { return t; } -static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, SV *name) { - SV *t; +static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, SV *name) { + AV *type_reifiers; + SV *t, *sv, **psv; int n; dSP; + type_reifiers = get_av(MY_PKG "::type_reifiers", 0); + assert(type_reifiers != NULL); + + if (spec->reify_type < 0 || spec->reify_type > av_len(type_reifiers)) { + croak("In %"SVf": internal error: reify_type [%ld] out of range [%ld]", SVfARG(declarator), (long)spec->reify_type, (long)(av_len(type_reifiers) + 1)); + } + + psv = av_fetch(type_reifiers, spec->reify_type, 0); + assert(psv != NULL); + sv = *psv; + ENTER; SAVETMPS; PUSHMARK(SP); - EXTEND(SP, 1); + EXTEND(SP, 2); PUSHs(name); + PUSHs(PL_curstname); PUTBACK; - n = call_pv("Moose::Util::TypeConstraints::find_or_create_isa_type_constraint", G_SCALAR); + n = call_sv(sv, G_SCALAR); SPAGAIN; assert(n == 1); @@ -773,13 +726,6 @@ static size_t count_named_params(const ParamSpec *ps) { return ps->named_required.used + ps->named_optional.used; } -static void my_require(pTHX_ const char *file) { - require_pv(file); - if (SvTRUE(ERRSV)) { - croak_sv(ERRSV); - } -} - static SV *my_eval(pTHX_ Sentinel sen, I32 floor, OP *op) { SV *sv; CV *cv; @@ -857,7 +803,9 @@ static PADOFFSET parse_param( sentinel_disarm(expr_sentinel); } *ptype = my_eval(aTHX_ sen, floor, expr); - *ptype = reify_type(aTHX_ sen, declarator, *ptype); + if (!SvROK(*ptype)) { + *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype); + } if (!sv_isobject(*ptype)) { croak("In %"SVf": (%"SVf") doesn't look like a type object", SVfARG(declarator), SVfARG(*ptype)); } @@ -865,8 +813,7 @@ static PADOFFSET parse_param( c = lex_peek_unichar(0); } else if (MY_UNI_IDFIRST(c)) { *ptype = parse_type(aTHX_ sen, declarator); - my_require(aTHX_ "Moose/Util/TypeConstraints.pm"); - *ptype = reify_type(aTHX_ sen, declarator, *ptype); + *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype); c = lex_peek_unichar(0); } @@ -1035,10 +982,11 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const mPUSHu(key); } /* 1 */ { - size_t n; + STRLEN n; char *p = SvPV(declarator, n); char *q = memchr(p, ' ', n); - mPUSHp(p, q ? (size_t)(q - p) : n); + SV *tmp = newSVpvn_utf8(p, q ? (size_t)(q - p) : n, SvUTF8(declarator)); + mPUSHs(tmp); } if (!ps) { if (SvTRUE(kws->shift)) { @@ -1175,6 +1123,9 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL I32 c; declarator = sentinel_mortalize(sen, newSVpvn(keyword_ptr, keyword_len)); + if (lex_bufutf8()) { + SvUTF8_on(declarator); + } lex_read_space(0); @@ -1461,7 +1412,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } /* surprise predeclaration! */ - if (saw_name) { + if (saw_name && !(spec->flags & FLAG_RUNTIME)) { /* 'sub NAME (PROTO);' to make name/proto known to perl before it starts parsing the body */ const I32 sub_ix = start_subparse(FALSE, 0); @@ -1965,6 +1916,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL /* it's go time. */ { + int runtime = spec->flags & FLAG_RUNTIME; CV *cv; OP *const attrs = op_guard_relinquish(attrs_sentinel); @@ -1975,8 +1927,8 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL cv = newATTRSUB( floor_ix, - saw_name ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL, - proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, + saw_name && !runtime ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL, + proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, attrs, body ); @@ -1986,7 +1938,25 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } if (saw_name) { - *pop = newOP(OP_NULL, 0); + if (!runtime) { + *pop = newOP(OP_NULL, 0); + } else { + *pop = newUNOP( + OP_ENTERSUB, OPf_STACKED, + op_append_elem( + OP_LIST, + op_append_elem( + OP_LIST, + mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)), + newUNOP( + OP_REFGEN, 0, + newSVOP(OP_ANONCODE, 0, (SV *)cv) + ) + ), + newCVREF(0, newGVOP(OP_GV, 0, gv_fetchpvs(MY_PKG "::_defun", 0, SVt_PVCV))) + ) + ); + } return KEYWORD_PLUGIN_STMT; } @@ -2001,28 +1971,123 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } } +static int kw_flags_enter(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, KWSpec *spec) { + HV *hints; + SV *sv, **psv; + const char *p, *kw_active; + STRLEN kw_active_len; + bool kw_is_utf8; + + 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; + } + + kw_is_utf8 = lex_bufutf8(); + + 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 + ) { + ENTER; + SAVETMPS; + + SAVEDESTRUCTOR_X(sentinel_clear_void, sen); + + spec->flags = 0; + spec->reify_type = 0; + spec->shift = sentinel_mortalize(sen, newSVpvs("")); + spec->attrs = sentinel_mortalize(sen, newSVpvs("")); + +#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \ + const char *fk_ptr_; \ + STRLEN fk_len_; \ + I32 fk_xlen_; \ + SV *fk_sv_; \ + fk_sv_ = sentinel_mortalize(sen, newSVpvs(HINTK_ ## NAME)); \ + sv_catpvn(fk_sv_, PTR, LEN); \ + fk_ptr_ = SvPV(fk_sv_, fk_len_); \ + fk_xlen_ = fk_len_; \ + if (kw_is_utf8) { \ + fk_xlen_ = -fk_xlen_; \ + } \ + if (!((X) = hv_fetch(hints, fk_ptr_, fk_xlen_, 0))) { \ + croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \ + } \ +} STMT_END + + FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv); + spec->flags = SvIV(*psv); + + FETCH_HINTK_INTO(REIFY_, kw_ptr, kw_len, psv); + spec->reify_type = 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; +} + static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { + Sentinel sen = { NULL }; KWSpec spec; int ret; - Sentinel sen = { NULL }; - - ENTER; - SAVETMPS; - - SAVEDESTRUCTOR_X(sentinel_clear_void, sen); - if (kw_flags(aTHX_ sen, keyword_ptr, keyword_len, &spec)) { + if (kw_flags_enter(aTHX_ sen, keyword_ptr, keyword_len, &spec)) { + /* scope was entered, 'sen' and 'spec' are initialized */ ret = parse_fun(aTHX_ sen, op_ptr, keyword_ptr, keyword_len, &spec); + FREETMPS; + LEAVE; } else { + /* not one of our keywords, no allocation done */ ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } - FREETMPS; - LEAVE; - return ret; } +#ifndef SvREFCNT_dec_NN +#define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV) +#endif + +#ifndef assert_ +#ifdef DEBUGGING +#define assert_(X) assert(X), +#else +#define assert_(X) +#endif +#endif + +#ifndef gv_method_changed +#define gv_method_changed(GV) ( \ + assert_(isGV_with_GP(GV)) \ + GvREFCNT(GV) > 1 \ + ? (void)PL_sub_generation++ \ + : mro_method_changed_in(GvSTASH(GV)) \ +) +#endif + WARNINGS_RESET MODULE = Function::Parameters PACKAGE = Function::Parameters PREFIX = fp_ @@ -2030,7 +2095,7 @@ PROTOTYPES: ENABLE UV fp__cv_root(sv) - SV * sv + SV *sv PREINIT: CV *xcv; HV *hv; @@ -2041,6 +2106,32 @@ fp__cv_root(sv) OUTPUT: RETVAL +void +fp__defun(name, body) + SV *name + CV *body + PREINIT: + GV *gv; + CV *xcv; + CODE: + assert(SvTYPE(body) == SVt_PVCV); + gv = gv_fetchsv(name, GV_ADDMULTI, SVt_PVCV); + xcv = GvCV(gv); + if (xcv) { + if (!GvCVGEN(gv) && (CvROOT(xcv) || CvXSUB(xcv)) && ckWARN(WARN_REDEFINE)) { + warner(packWARN(WARN_REDEFINE), "Subroutine %"SVf" redefined", SVfARG(name)); + } + SvREFCNT_dec_NN(xcv); + } + GvCVGEN(gv) = 0; + GvASSUMECV_on(gv); + if (GvSTASH(gv)) { + gv_method_changed(gv); + } + GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(body)); + CvGV_set(body, gv); + CvANON_off(body); + BOOT: WARNINGS_ENABLE { HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); @@ -2053,10 +2144,12 @@ WARNINGS_ENABLE { newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS)); newCONSTSUB(stash, "FLAG_TYPES_OK", newSViv(FLAG_TYPES_OK)); newCONSTSUB(stash, "FLAG_CHECK_TARGS", newSViv(FLAG_CHECK_TARGS)); + newCONSTSUB(stash, "FLAG_RUNTIME", newSViv(FLAG_RUNTIME)); newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); + newCONSTSUB(stash, "HINTK_REIFY_", newSVpvs(HINTK_REIFY_)); /**/ next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin;