From: Lukas Mai Date: Wed, 14 Nov 2012 14:12:23 +0000 (+0100) Subject: Merge branch 'metadata' into mooseish-types X-Git-Tag: v1.00_02~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFunction-Parameters.git;a=commitdiff_plain;h=5cf69cd2971747fcdf9118fcfdf5b6d1869ad508;hp=43a9d07b4f3e1803984e90310880c80c85a7149d Merge branch 'metadata' into mooseish-types --- diff --git a/MANIFEST b/MANIFEST index 1c86126..690db90 100644 --- a/MANIFEST +++ b/MANIFEST @@ -81,6 +81,7 @@ t/invocant.t t/lexical.t t/lineno-torture.t t/lineno.t +t/moose_types.t t/name.t t/name_1.fail t/name_2.fail diff --git a/Parameters.xs b/Parameters.xs index 9418c07..ba28c0e 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -96,7 +96,9 @@ enum { FLAG_DEFAULT_ARGS = 0x04, FLAG_CHECK_NARGS = 0x08, FLAG_INVOCANT = 0x10, - FLAG_NAMED_PARAMS = 0x20 + FLAG_NAMED_PARAMS = 0x20, + FLAG_TYPES_OK = 0x40, + FLAG_CHECK_TARGS = 0x80 }; DEFSTRUCT(KWSpec) { @@ -119,7 +121,9 @@ static void sentinel_clear_void(pTHX_ void *p) { Resource **pp = p; while (*pp) { Resource *cur = *pp; - cur->destroy(aTHX_ cur->data); + if (cur->destroy) { + cur->destroy(aTHX_ cur->data); + } cur->data = (void *)"no"; cur->destroy = NULL; *pp = cur->next; @@ -127,7 +131,7 @@ static void sentinel_clear_void(pTHX_ void *p) { } } -static void sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ void *)) { +static Resource *sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ void *)) { Resource *cur; Newx(cur, 1, Resource); @@ -135,6 +139,12 @@ static void sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ vo cur->destroy = destroy; cur->next = *sen; *sen = cur; + + return cur; +} + +static void sentinel_disarm(Resource *p) { + p->destroy = NULL; } static void my_sv_refcnt_dec_void(pTHX_ void *p) { @@ -242,12 +252,17 @@ static int kw_flags(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, KWSpe } -static void free_ptr_op(pTHX_ void *vp) { +static void free_ptr_op_void(pTHX_ void *vp) { OP **pp = vp; op_free(*pp); Safefree(pp); } +static void free_op_void(pTHX_ void *vp) { + OP *p = vp; + op_free(p); +} + #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1) static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { @@ -489,10 +504,97 @@ static void my_check_prototype(pTHX_ Sentinel sen, const SV *declarator, SV *pro } } +static SV *parse_type(pTHX_ Sentinel, const SV *); + +static SV *parse_type_paramd(pTHX_ Sentinel sen, const SV *declarator) { + I32 c; + SV *t; + + t = my_scan_word(aTHX_ sen, TRUE); + lex_read_space(0); + + c = lex_peek_unichar(0); + if (c == '[') { + SV *u; + + lex_read_unichar(0); + lex_read_space(0); + my_sv_cat_c(aTHX_ t, c); + + u = parse_type(aTHX_ sen, declarator); + sv_catsv(t, u); + + c = lex_peek_unichar(0); + if (c != ']') { + croak("In %"SVf": missing ']' after '%"SVf"'", SVfARG(declarator), SVfARG(t)); + } + lex_read_unichar(0); + lex_read_space(0); + + my_sv_cat_c(aTHX_ t, c); + } + + return t; +} + +static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator) { + I32 c; + SV *t; + + t = parse_type_paramd(aTHX_ sen, declarator); + + c = lex_peek_unichar(0); + while (c == '|') { + SV *u; + + lex_read_unichar(0); + lex_read_space(0); + + my_sv_cat_c(aTHX_ t, c); + u = parse_type_paramd(aTHX_ sen, declarator); + sv_catsv(t, u); + + c = lex_peek_unichar(0); + } + + return t; +} + +static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, SV *name) { + SV *t; + int n; + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 1); + PUSHs(name); + PUTBACK; + + n = call_pv("Moose::Util::TypeConstraints::find_or_parse_type_constraint", G_SCALAR); + SPAGAIN; + + assert(n == 1); + t = sentinel_mortalize(sen, SvREFCNT_inc(POPs)); + + PUTBACK; + FREETMPS; + LEAVE; + + if (!SvTRUE(t)) { + croak("In %"SVf": undefined type '%"SVf"'", SVfARG(declarator), SVfARG(name)); + } + + return t; +} + DEFSTRUCT(Param) { SV *name; PADOFFSET padoff; + SV *type; }; DEFSTRUCT(ParamInit) { @@ -532,6 +634,7 @@ DEFVECTOR_INIT(piv_init, ParamInit); static void p_init(Param *p) { p->name = NULL; p->padoff = NOT_IN_PAD; + p->type = NULL; } static void ps_init(ParamSpec *ps) { @@ -570,6 +673,7 @@ DEFVECTOR_EXTEND(piv_extend, ParamInit); static void p_clear(pTHX_ Param *p) { p->name = NULL; p->padoff = NOT_IN_PAD; + p->type = NULL; } static void pi_clear(pTHX_ ParamInit *pi) { @@ -671,6 +775,35 @@ 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; + dSP; + + cv = newATTRSUB(floor, NULL, NULL, NULL, op); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + call_sv((SV *)cv, G_SCALAR | G_NOARGS); + SPAGAIN; + sv = sentinel_mortalize(sen, SvREFCNT_inc(POPs)); + + PUTBACK; + FREETMPS; + LEAVE; + + return sv; +} + enum { PARAM_INVOCANT = 0x01, PARAM_NAMED = 0x02 @@ -683,7 +816,7 @@ static PADOFFSET parse_param( pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, ParamSpec *param_spec, - int *pflags, SV **pname, OP **pinit + int *pflags, SV **pname, OP **pinit, SV **ptype ) { I32 c; char sigil; @@ -691,9 +824,53 @@ static PADOFFSET parse_param( assert(!*pinit); *pflags = 0; + *ptype = NULL; c = lex_peek_unichar(0); + if (spec->flags & FLAG_TYPES_OK) { + if (c == '(') { + I32 floor; + OP *expr; + Resource *expr_sentinel; + + lex_read_unichar(0); + + floor = start_subparse(FALSE, 0); + SAVEFREESV(PL_compcv); + CvSPECIAL_on(PL_compcv); + + if (!(expr = parse_fullexpr(PARSE_OPTIONAL))) { + croak("In %"SVf": invalid type expression", SVfARG(declarator)); + } + expr_sentinel = sentinel_register(sen, expr, free_op_void); + + lex_read_space(0); + c = lex_peek_unichar(0); + if (c != ')') { + croak("In %"SVf": missing ')' after type expression", SVfARG(declarator)); + } + lex_read_unichar(0); + lex_read_space(0); + + SvREFCNT_inc_simple_void(PL_compcv); + sentinel_disarm(expr_sentinel); + *ptype = my_eval(aTHX_ sen, floor, expr); + *ptype = reify_type(aTHX_ sen, declarator, *ptype); + if (!sv_isobject(*ptype)) { + croak("In %"SVf": (%"SVf") doesn't look like a type object", SVfARG(declarator), SVfARG(*ptype)); + } + + c = lex_peek_unichar(0); + } else if (my_is_uni_xidfirst(aTHX_ c)) { + *ptype = parse_type(aTHX_ sen, declarator); + my_require(aTHX_ "Moose/Util/TypeConstraints.pm"); + *ptype = reify_type(aTHX_ sen, declarator, *ptype); + + c = lex_peek_unichar(0); + } + } + if (c == ':') { lex_read_unichar(0); lex_read_space(0); @@ -706,6 +883,7 @@ static PADOFFSET parse_param( if (c == -1) { croak("In %"SVf": unterminated parameter list", SVfARG(declarator)); } + if (!(c == '$' || c == '@' || c == '%')) { croak("In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c); } @@ -786,6 +964,63 @@ static OP *mkconstpv(pTHX_ const char *p, size_t n) { #define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1) +static OP *mktypecheck(pTHX_ const SV *declarator, int nr, SV *name, PADOFFSET padoff, SV *type) { + /* $type->check($value) or Carp::croak "...: " . $type->get_message($value) */ + OP *chk, *cond, *err, *msg, *xcroak; + + err = mkconstsv(aTHX_ newSVpvf("In %"SVf": parameter %d (%"SVf"): ", SVfARG(declarator), nr, SVfARG(name))); + { + OP *args = NULL; + + args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); + args = op_append_elem( + OP_LIST, args, + padoff == NOT_IN_PAD + ? S_newDEFSVOP(aTHX) + : my_var(aTHX_ 0, padoff) + ); + args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("get_message"))); + + msg = args; + msg->op_type = OP_ENTERSUB; + msg->op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + msg->op_flags |= OPf_STACKED; + } + + msg = newBINOP(OP_CONCAT, 0, err, msg); + + xcroak = newCVREF( + OPf_WANT_SCALAR, + newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)) + ); + xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak)); + + { + OP *args = NULL; + + args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); + args = op_append_elem( + OP_LIST, args, + padoff == NOT_IN_PAD + ? S_newDEFSVOP(aTHX) + : my_var(aTHX_ 0, padoff) + ); + args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("check"))); + + chk = args; + chk->op_type = OP_ENTERSUB; + chk->op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + chk->op_flags |= OPf_STACKED; + } + + chk = newLOGOP(OP_OR, 0, chk, xcroak); + return chk; +} + +static OP *mktypecheckp(pTHX_ const SV *declarator, int nr, const Param *param) { + return mktypecheck(aTHX_ declarator, nr, param->name, param->padoff, param->type); +} + static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const ParamSpec *ps) { dSP; @@ -793,7 +1028,7 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const SAVETMPS; PUSHMARK(SP); - EXTEND(SP, 8); + EXTEND(SP, 10); /* 0 */ { mPUSHu(key); @@ -810,20 +1045,28 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const } else { PUSHmortal; } + PUSHmortal; mPUSHs(newRV_noinc((SV *)newAV())); mPUSHs(newRV_noinc((SV *)newAV())); mPUSHs(newRV_noinc((SV *)newAV())); mPUSHs(newRV_noinc((SV *)newAV())); mPUSHp("@_", 2); + PUSHmortal; } else { - /* 2 */ { + /* 2, 3 */ { if (ps->invocant.name) { PUSHs(ps->invocant.name); + if (ps->invocant.type) { + PUSHs(ps->invocant.type); + } else { + PUSHmortal; + } } else { PUSHmortal; + PUSHmortal; } } - /* 3 */ { + /* 4 */ { size_t i, lim; AV *av; @@ -831,15 +1074,17 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const av = newAV(); if (lim) { - av_extend(av, lim - 1); + av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { - av_push(av, SvREFCNT_inc_simple_NN(ps->positional_required.data[i].name)); + Param *cur = &ps->positional_required.data[i]; + av_push(av, SvREFCNT_inc_simple_NN(cur->name)); + av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } - /* 4 */ { + /* 5 */ { size_t i, lim; AV *av; @@ -847,15 +1092,17 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const av = newAV(); if (lim) { - av_extend(av, lim - 1); + av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { - av_push(av, SvREFCNT_inc_simple_NN(ps->positional_optional.data[i].param.name)); + Param *cur = &ps->positional_optional.data[i].param; + av_push(av, SvREFCNT_inc_simple_NN(cur->name)); + av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } - /* 5 */ { + /* 6 */ { size_t i, lim; AV *av; @@ -863,15 +1110,17 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const av = newAV(); if (lim) { - av_extend(av, lim - 1); + av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { - av_push(av, SvREFCNT_inc_simple_NN(ps->named_required.data[i].name)); + Param *cur = &ps->named_required.data[i]; + av_push(av, SvREFCNT_inc_simple_NN(cur->name)); + av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } - /* 6 */ { + /* 7 */ { size_t i, lim; AV *av; @@ -879,19 +1128,27 @@ static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const av = newAV(); if (lim) { - av_extend(av, lim - 1); + av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { - av_push(av, SvREFCNT_inc_simple_NN(ps->named_optional.data[i].param.name)); + Param *cur = &ps->named_optional.data[i].param; + av_push(av, SvREFCNT_inc_simple_NN(cur->name)); + av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } - /* 7 */ { + /* 8, 9 */ { if (ps->slurpy.name) { PUSHs(ps->slurpy.name); + if (ps->slurpy.type) { + PUSHs(ps->slurpy.type); + } else { + PUSHmortal; + } } else { PUSHmortal; + PUSHmortal; } } } @@ -960,7 +1217,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL /* initialize synthetic optree */ Newx(prelude_sentinel, 1, OP *); *prelude_sentinel = NULL; - sentinel_register(sen, prelude_sentinel, free_ptr_op); + sentinel_register(sen, prelude_sentinel, free_ptr_op_void); /* parameters */ param_spec = NULL; @@ -971,7 +1228,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL Newx(init_sentinel, 1, OP *); *init_sentinel = NULL; - sentinel_register(sen, init_sentinel, free_ptr_op); + sentinel_register(sen, init_sentinel, free_ptr_op_void); Newx(param_spec, 1, ParamSpec); ps_init(param_spec); @@ -982,11 +1239,11 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL while ((c = lex_peek_unichar(0)) != ')') { int flags; - SV *name; + SV *name, *type; char sigil; PADOFFSET padoff; - padoff = parse_param(aTHX_ sen, declarator, spec, param_spec, &flags, &name, init_sentinel); + padoff = parse_param(aTHX_ sen, declarator, spec, param_spec, &flags, &name, init_sentinel, &type); S_intro_my(aTHX); @@ -1019,6 +1276,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL assert(!*init_sentinel); param_spec->slurpy.name = name; param_spec->slurpy.padoff = padoff; + param_spec->slurpy.type = type; continue; } @@ -1038,6 +1296,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } param_spec->invocant.name = name; param_spec->invocant.padoff = padoff; + param_spec->invocant.type = type; continue; } @@ -1058,6 +1317,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL ParamInit *pi = piv_extend(¶m_spec->named_optional); pi->param.name = name; pi->param.padoff = padoff; + pi->param.type = type; pi->init = *init_sentinel; *init_sentinel = NULL; param_spec->named_optional.used++; @@ -1071,6 +1331,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL p = pv_extend(¶m_spec->named_required); p->name = name; p->padoff = padoff; + p->type = type; param_spec->named_required.used++; } } else { @@ -1078,6 +1339,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL ParamInit *pi = piv_extend(¶m_spec->positional_optional); pi->param.name = name; pi->param.padoff = padoff; + pi->param.type = type; pi->init = *init_sentinel; *init_sentinel = NULL; param_spec->positional_optional.used++; @@ -1085,6 +1347,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL Param *p = pv_extend(¶m_spec->positional_required); p->name = name; p->padoff = padoff; + p->type = type; param_spec->positional_required.used++; } } @@ -1133,7 +1396,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL /* attributes */ Newx(attrs_sentinel, 1, OP *); *attrs_sentinel = NULL; - sentinel_register(sen, attrs_sentinel, free_ptr_op); + sentinel_register(sen, attrs_sentinel, free_ptr_op_void); if (c == ':' || c == '{') /* '}' - hi, vim */ { @@ -1350,6 +1613,10 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); + + if (param_spec->invocant.type && (spec->flags & FLAG_CHECK_TARGS)) { + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, 0, ¶m_spec->invocant))); + } } /* my (...) = @_; */ @@ -1626,6 +1893,65 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, clear)); } } + + if (spec->flags & FLAG_CHECK_TARGS) { + size_t i, lim, base; + + base = 1; + for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) { + Param *cur = ¶m_spec->positional_required.data[i]; + + if (cur->type) { + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, base + i, cur))); + } + } + base += i; + + for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) { + Param *cur = ¶m_spec->positional_optional.data[i].param; + + if (cur->type) { + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, base + i, cur))); + } + } + base += i; + + for (i = 0, lim = param_spec->named_required.used; i < lim; i++) { + Param *cur = ¶m_spec->named_required.data[i]; + + if (cur->type) { + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, base + i, cur))); + } + } + base += i; + + for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) { + Param *cur = ¶m_spec->named_optional.data[i].param; + + if (cur->type) { + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, base + i, cur))); + } + } + base += i; + + if (param_spec->slurpy.type) { + /* $type->valid($_) or croak $type->get_message($_) for @rest / values %rest */ + OP *body, *list, *loop; + + body = mktypecheck(aTHX_ declarator, base, param_spec->slurpy.name, NOT_IN_PAD, param_spec->slurpy.type); + + if (SvPV_nolen(param_spec->slurpy.name)[0] == '@') { + list = my_var_g(aTHX_ OP_PADAV, 0, param_spec->slurpy.padoff); + } else { + list = my_var_g(aTHX_ OP_PADHV, 0, param_spec->slurpy.padoff); + list = newUNOP(OP_VALUES, 0, list); + } + + loop = newFOROP(0, NULL, list, body, NULL); + + *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, loop)); + } + } } /* finally let perl parse the actual subroutine body */ @@ -1728,6 +2054,8 @@ WARNINGS_ENABLE { newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT)); 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, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index c67e6ec..916bc50 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -32,12 +32,14 @@ my %type_map = ( default_arguments => 1, check_argument_count => 0, named_parameters => 1, + types => 1, }, method => { name => 'optional', default_arguments => 1, check_argument_count => 0, named_parameters => 1, + types => 1, attrs => ':method', shift => '$self', invocant => 1, @@ -47,6 +49,7 @@ my %type_map = ( default_arguments => 1, check_argument_count => 0, named_parameters => 1, + types => 1, attributes => ':method', shift => '$class', invocant => 1, @@ -116,6 +119,7 @@ sub import { $clean{check_argument_count} = !!delete $type{check_argument_count}; $clean{invocant} = !!delete $type{invocant}; $clean{named_parameters} = !!delete $type{named_parameters}; + $clean{types} = !!delete $type{types}; %type and confess "Invalid keyword property: @{[keys %type]}"; @@ -131,9 +135,10 @@ sub import { FLAG_ANON_OK | FLAG_NAME_OK ; $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; - $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; + $flags |= FLAG_CHECK_NARGS | FLAG_CHECK_TARGS if $type->{check_argument_count}; $flags |= FLAG_INVOCANT if $type->{invocant}; $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters}; + $flags |= FLAG_TYPES_OK if $type->{types}; $^H{HINTK_FLAGS_ . $kw} = $flags; $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; @@ -162,40 +167,58 @@ sub _register_info { $key, $declarator, $invocant, + $invocant_type, $positional_required, $positional_optional, $named_required, $named_optional, $slurpy, + $slurpy_type, ) = @_; - my $blob = pack '(Z*)*', - $declarator, - $invocant // '', - join(' ', @$positional_required), - join(' ', @$positional_optional), - join(' ', @$named_required), - join(' ', @$named_optional), - $slurpy // '', - ; - - $metadata{$key} = $blob; + my $info = { + declarator => $declarator, + invocant => defined $invocant ? [$invocant, $invocant_type] : undef, + slurpy => defined $slurpy ? [$slurpy , $slurpy_type ] : undef, + positional_required => $positional_required, + positional_optional => $positional_optional, + named_required => $named_required, + named_optional => $named_optional, + }; + + $metadata{$key} = $info; +} + +sub _mkparam1 { + my ($pair) = @_; + my ($v, $t) = @{$pair || []} or return undef; + Function::Parameters::Param->new( + name => $v, + type => $t, + ) +} + +sub _mkparams { + my @r; + while (my ($v, $t) = splice @_, 0, 2) { + push @r, Function::Parameters::Param->new( + name => $v, + type => $t, + ); + } + \@r } sub info { my ($func) = @_; my $key = _cv_root $func or return undef; - my $blob = $metadata{$key} or return undef; - my @info = unpack '(Z*)*', $blob; + my $info = $metadata{$key} or return undef; require Function::Parameters::Info; Function::Parameters::Info->new( - keyword => $info[0], - invocant => $info[1] || undef, - _positional_required => [split ' ', $info[2]], - _positional_optional => [split ' ', $info[3]], - _named_required => [split ' ', $info[4]], - _named_optional => [split ' ', $info[5]], - slurpy => $info[6] || undef, + keyword => $info->{declarator}, + invocant => _mkparam1($info->{invocant}), + slurpy => _mkparam1($info->{slurpy}), + (map +("_$_" => _mkparams @{$info->{$_}}), glob '{positional,named}_{required,optional}') ) } @@ -636,6 +659,44 @@ affects the file that is currently being compiled. # or Function::Parameters->import(@custom_import_args); } +=head2 Experimental feature: Types + +An experimental feature is now available: You can annotate parameters with +L. That is, before each parameter you can put +a type specification consisting of identifiers (C), unions (C<... | ...>), +and parametric types (C<...[...]>). Example: + + fun foo(Int $n, ArrayRef[String | CodeRef] $cb) { ... } + +If you do this, L will be loaded automatically (if that hasn't happened +yet). These specifications are parsed and validated using +L|Moose::Util::TypeConstraints/find_or_parse_type_constraint>. + +If you are in "lax" mode, nothing further happens and the types are ignored. If +you are in "strict" mode, C generates code to make sure +any values passed in conform to the type (via +L<< C<< $constraint->check($value) >>|Moose::Meta::TypeConstraint/$constraint->check($value) >>. + +In addition, these type constraints are inspectable through the +L object returned by +L|/Introspection>. + +=head2 Experimental experimental feature: Type expressions + +An even more experimental feature is the ability to specify arbitrary +expressions as types. The syntax for this is like the literal types described +above, but with an expression wrapped in parentheses (C<( EXPR )>). Example: + + fun foo(('Int') $n, ($othertype) $x) { ... } + +Every type expression must return either a string (which is resolved as for +literal types), or a L +(providing C and C methods). + +Note that these expressions are evaluated (once) at parse time (similar to +C blocks), so make sure that any variables you use are set and any +functions you call are defined at parse time. + =head2 How it works The module is actually written in L and uses @@ -653,6 +714,39 @@ generated code corresponds to: # ... turns into ... sub bar :method { my $self = shift; my ($x, $y, @z) = @_; sub bar; ... } +=head1 SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc Function::Parameters + +You can also look for information at: + +=over + +=item MetaCPAN + +L + +=item RT, CPAN's request tracker + +L + +=item AnnoCPAN, Annotated CPAN documentation + +L + +=item CPAN Ratings + +L + +=item Search CPAN + +L + +=back + =head1 SEE ALSO L diff --git a/lib/Function/Parameters/Info.pm b/lib/Function/Parameters/Info.pm index ac2b466..6755fee 100644 --- a/lib/Function/Parameters/Info.pm +++ b/lib/Function/Parameters/Info.pm @@ -8,6 +8,18 @@ use Moo; our $VERSION = '0.01'; +{ + package Function::Parameters::Param; + + use Moo; + use overload + fallback => 1, + '""' => sub { $_[0]->name }, + ; + + has $_ => (is => 'ro') for qw(name type); +} + my @pn_ro = glob '{positional,named}_{required,optional}'; for my $attr (qw[keyword invocant slurpy], map "_$_", @pn_ro) { @@ -123,6 +135,18 @@ Returns the maximum number of arguments this function accepts. This is computed as follows: If there is any named or slurpy parameter, the result is C. Otherwise the result is the sum of all invocant and positional parameters. +=head2 Experimental feature: Types + +All the methods described above actually return parameter objects wherever the +description says "name". These objects have two methods: C, which +returns the name of the parameter (as a plain string), and C, which +returns the corresponding type constraint object (or undef if there was no type +specified). + +This should be invisible if you don't use types because the objects also +L stringification to call C. That is, if you treat +parameter objects like strings, they behave like strings (i.e. their names). + =head1 SEE ALSO L diff --git a/padop_on_crack.c.inc b/padop_on_crack.c.inc index 28078a7..89dc27b 100644 --- a/padop_on_crack.c.inc +++ b/padop_on_crack.c.inc @@ -1052,6 +1052,23 @@ static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) { #endif +#ifndef pad_findmy_pvs + #define pad_findmy_pvs(S, FLAGS) S_pad_findmy(aTHX_ "" S "", FLAGS) +#endif + +static OP *S_newDEFSVOP(pTHX) { + dVAR; + const PADOFFSET offset = pad_findmy_pvs("$_", 0); + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { + return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); + } + else { + OP * const o = newOP(OP_PADSV, 0); + o->op_targ = offset; + return o; + } +} + static U32 S_intro_my(pTHX) { dVAR; SV **svp; diff --git a/t/moose_types.t b/t/moose_types.t new file mode 100644 index 0000000..1f5344d --- /dev/null +++ b/t/moose_types.t @@ -0,0 +1,131 @@ +#!perl +use warnings FATAL => 'all'; +use strict; + +use Test::More + eval { require Moose; 1 } + ? (tests => 49) + : (skip_all => "Moose required for testing types") +; +use Test::Fatal; + +use Function::Parameters qw(:strict); + +fun foo(Int $n, CodeRef $f, $x) { + $x = $f->($x) for 1 .. $n; + $x +} + +is foo(0, fun {}, undef), undef; +is foo(0, fun {}, "o hai"), "o hai"; +is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; +is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; + +{ + my $info = Function::Parameters::info \&foo; + is $info->invocant, undef; + is $info->slurpy, undef; + is $info->positional_optional, 0; + is $info->named_required, 0; + is $info->named_optional, 0; + my @req = $info->positional_required; + is @req, 3; + is $req[0]->name, '$n'; + ok $req[0]->type->equals('Int'); + is $req[1]->name, '$f'; + ok $req[1]->type->equals('CodeRef'); + is $req[2]->name, '$x'; + is $req[2]->type, undef; +} + +like exception { foo("ermagerd", fun {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; +like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; + +fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } + +is bar(21), 42; +{ + my $info = Function::Parameters::info \&bar; + is $info->invocant, undef; + is $info->slurpy, undef; + is $info->positional_optional, 0; + is $info->named_required, 0; + is $info->named_optional, 0; + my @req = $info->positional_required; + is @req, 1; + is $req[0]->name, '$whoa'; + ok $req[0]->type->equals('Int'); +} + +{ + my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); + is $info->invocant, undef; + is $info->positional_required, 0; + is $info->positional_optional, 0; + is $info->named_required, 0; + is $info->named_optional, 0; + my $slurpy = $info->slurpy; + is $slurpy->name, '@nom'; + ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); +} + +{ + my $phase = 'runtime'; + BEGIN { $phase = 'A'; } + fun + baz + ( + ( + is + ( + $phase + ++ + , + 'A' + ) + , + 'Int' + ) + : + $marco + , + ( + is + ( + $phase + ++ + , + 'B' + ) + , + q + $ArrayRef[Str]$ + ) + : + $polo + ) + { + [ + $marco + , + $polo + ] + } + BEGIN { is $phase, 'C'; } + is $phase, 'runtime'; + + is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; + + my $info = Function::Parameters::info \&baz; + is $info->invocant, undef; + is $info->slurpy, undef; + is $info->positional_required, 0; + is $info->positional_optional, 0; + is $info->named_optional, 0; + my @req = $info->named_required; + is @req, 2; + is $req[0]->name, '$marco'; + ok $req[0]->type->equals('Int'); + is $req[1]->name, '$polo'; + ok $req[1]->type->equals('ArrayRef[Str]'); +}