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) {
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;
}
}
-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);
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) {
}
-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) {
}
}
+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);
+ /* don't warn about n being unused if assert() is compiled out */
+ n = n;
+
+ 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) {
static void p_init(Param *p) {
p->name = NULL;
p->padoff = NOT_IN_PAD;
+ p->type = NULL;
}
static void ps_init(ParamSpec *ps) {
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) {
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
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;
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);
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);
}
#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, *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;
SAVETMPS;
PUSHMARK(SP);
- EXTEND(SP, 8);
+ EXTEND(SP, 10);
/* 0 */ {
mPUSHu(key);
} 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;
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;
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;
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;
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;
}
}
}
/* 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;
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);
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);
assert(!*init_sentinel);
param_spec->slurpy.name = name;
param_spec->slurpy.padoff = padoff;
+ param_spec->slurpy.type = type;
continue;
}
}
param_spec->invocant.name = name;
param_spec->invocant.padoff = padoff;
+ param_spec->invocant.type = type;
continue;
}
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++;
p = pv_extend(¶m_spec->named_required);
p->name = name;
p->padoff = padoff;
+ p->type = type;
param_spec->named_required.used++;
}
} else {
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++;
Param *p = pv_extend(¶m_spec->positional_required);
p->name = name;
p->padoff = padoff;
+ p->type = type;
param_spec->positional_required.used++;
}
}
/* 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 */ {
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 (...) = @_; */
*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 *check, *list, *loop;
+
+ check = 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, check, NULL);
+
+ *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, loop));
+ }
+ }
}
/* finally let perl parse the actual subroutine body */
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_));
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,
default_arguments => 1,
check_argument_count => 0,
named_parameters => 1,
+ types => 1,
attributes => ':method',
shift => '$class',
invocant => 1,
$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]}";
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};
$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}')
)
}
# or Function::Parameters->import(@custom_import_args);
}
+=head2 Experimental feature: Types
+
+An experimental feature is now available: You can annotate parameters with
+L<Moose types|Moose::Manual::Types>. That is, before each parameter you can put
+a type specification consisting of identifiers (C<Foo>), unions (C<... | ...>),
+and parametric types (C<...[...]>). Example:
+
+ fun foo(Int $n, ArrayRef[String | CodeRef] $cb) { ... }
+
+If you do this, L<Moose> will be loaded automatically (if that hasn't happened
+yet). These specifications are parsed and validated using
+L<C<Moose::Util::TypeConstraints::find_or_parse_type_constraint>|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<Function::Parameters> 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<Function::Parameters::Info> object returned by
+L<C<Function::Parameters::info>|/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<type constraint object|Moose::Meta::TypeConstraint>
+(providing C<check> and C<get_message> methods).
+
+Note that these expressions are evaluated (once) at parse time (similar to
+C<BEGIN> 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<C|perlxs> and uses
# ... 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<https://metacpan.org/module/Function%3A%3AParameters>
+
+=item RT, CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Function-Parameters>
+
+=item AnnoCPAN, Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Function-Parameters>
+
+=item CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Function-Parameters>
+
+=item Search CPAN
+
+L<http://search.cpan.org/dist/Function-Parameters/>
+
+=back
+
=head1 SEE ALSO
L<Function::Parameters::Info>
--- /dev/null
+#!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]');
+}