From: Lukas Mai Date: Fri, 22 Jun 2012 10:47:19 +0000 (+0200) Subject: default params/strict arg count checks, working on ops X-Git-Tag: v0.06_01~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=63915d2641ec4983bb6b54e1ff7d30cd0032c40d;p=p5sagit%2FFunction-Parameters.git default params/strict arg count checks, working on ops --- diff --git a/Parameters.xs b/Parameters.xs index 904ea25..1dda3ad 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -49,14 +49,9 @@ See http://dev.perl.org/licenses/ for more information. #include + 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)))))) @@ -67,25 +62,45 @@ WARNINGS_ENABLE #define IF_HAVE_PERL_5_16(YES, NO) NO #endif -typedef struct { - enum { - FLAG_NAME_OPTIONAL = 1, - FLAG_NAME_REQUIRED, - FLAG_NAME_PROHIBITED - } name; + +#define MY_PKG "Function::Parameters" + +#define HINTK_KEYWORDS MY_PKG "/keywords" +#define HINTK_FLAGS_ MY_PKG "/flags:" +#define HINTK_SHIFT_ MY_PKG "/shift:" +#define HINTK_ATTRS_ MY_PKG "/attrs:" + +#define DEFSTRUCT(T) typedef struct T T; struct T + +DEFSTRUCT(DefaultParamSpec) { + DefaultParamSpec *next; + int limit; + SV *name; + OP *init; +}; + +enum { + FLAG_NAME_OK = 0x01, + FLAG_ANON_OK = 0x02, + FLAG_DEFAULT_ARGS = 0x04, + FLAG_CHECK_NARGS = 0x08 +}; + +DEFSTRUCT(KWSpec) { + unsigned flags; 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) { +static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) { HV *hints; SV *sv, **psv; const char *p, *kw_active; STRLEN kw_active_len; - spec->name = 0; + spec->flags = 0; spec->shift = sv_2mortal(newSVpvs("")); spec->attrs = sv_2mortal(newSVpvs("")); @@ -124,8 +139,8 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) { } \ } STMT_END - FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv); - spec->name = SvIV(*psv); + 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); @@ -144,6 +159,12 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) { #include "toke_on_crack.c.inc" +static void free_defspec(pTHX_ void *vp) { + DefaultParamSpec *dp = vp; + op_free(dp->init); + Safefree(dp); +} + static void free_ptr_op(pTHX_ void *vp) { OP **pp = vp; op_free(*pp); @@ -195,11 +216,14 @@ enum { MY_ATTR_SPECIAL = 0x04 }; -static int parse_fun(pTHX_ 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 KWSpec *spec) { SV *declarator; I32 floor_ix; + int save_ix; SV *saw_name; AV *params; + DefaultParamSpec *defaults; + int args_min, args_max; SV *proto; OP **attrs_sentinel, *body; unsigned builtin_attrs; @@ -216,7 +240,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len /* function name */ saw_name = NULL; s = PL_parser->bufptr; - if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) { + if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) { saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); if (PL_parser->expect != XSTATE) { @@ -239,20 +263,31 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len lex_read_to(s + len); lex_read_space(0); - } else if (spec->name == FLAG_NAME_REQUIRED) { + } else if (!(spec->flags & FLAG_ANON_OK)) { croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); } else { sv_catpvs(declarator, " (anon)"); } + /* we're a subroutine declaration */ floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); SAVEFREESV(PL_compcv); + /* create outer block: '{' */ + save_ix = S_block_start(aTHX_ TRUE); + /* parameters */ params = NULL; + defaults = NULL; + args_min = 0; + args_max = -1; + c = lex_peek_unichar(0); if (c == '(') { + DefaultParamSpec **pdefaults_tail = &defaults; SV *saw_slurpy = NULL; + int param_count = 0; + args_max = 0; lex_read_unichar(0); lex_read_space(0); @@ -263,8 +298,11 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len for (;;) { c = lex_peek_unichar(0); if (c == '$' || c == '@' || c == '%') { + const char sigil = c; SV *param; + param_count++; + lex_read_unichar(0); lex_read_space(0); @@ -272,11 +310,14 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len if (!(len = S_scan_word(aTHX_ s, FALSE))) { croak("In %"SVf": missing identifier", SVfARG(declarator)); } - param = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s)); + param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s)); if (saw_slurpy) { croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param)); } - if (c != '$') { + if (sigil == '$') { + args_max++; + } else { + args_max = -1; saw_slurpy = param; } av_push(params, SvREFCNT_inc_simple_NN(param)); @@ -284,6 +325,37 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len lex_read_space(0); c = lex_peek_unichar(0); + + if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) { + if (sigil == '$' && !defaults) { + args_min++; + } + } else if (sigil != '$') { + croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); + } else { + DefaultParamSpec *curdef; + + lex_read_unichar(0); + lex_read_space(0); + + Newx(curdef, 1, DefaultParamSpec); + curdef->next = NULL; + curdef->limit = param_count; + curdef->name = param; + curdef->init = NULL; + SAVEDESTRUCTOR_X(free_defspec, curdef); + + curdef->next = *pdefaults_tail; + *pdefaults_tail = curdef; + pdefaults_tail = &curdef->next; + + /* let perl parse the default parameter value */ + curdef->init = parse_termexpr(0); + + lex_read_space(0); + c = lex_peek_unichar(0); + } + if (c == ',') { lex_read_unichar(0); lex_read_space(0); @@ -326,31 +398,12 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len } } - /* surprise predeclaration! */ - if (saw_name) { - /* 'sub NAME (PROTO);' to make name/proto known to perl before it - starts parsing the body */ - SvREFCNT_inc_simple_void(PL_compcv); - - newATTRSUB( - floor_ix, - newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), - proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, - NULL, - NULL - ); - - floor_ix = start_subparse(FALSE, 0); - SAVEFREESV(PL_compcv); - } - - /* attributes */ Newx(attrs_sentinel, 1, OP *); *attrs_sentinel = NULL; SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel); - if (c == ':' || c == '{') { + if (c == ':' || c == '{') /* '}' - hi, vim */ { /* kludge default attributes in */ if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { @@ -410,10 +463,29 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len } /* body */ - if (c != '{') { + if (c != '{') /* '}' - hi, vim */ { croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); } + /* surprise predeclaration! */ + if (saw_name) { + /* 'sub NAME (PROTO);' to make name/proto known to perl before it + starts parsing the body */ + const I32 sub_ix = start_subparse(FALSE, 0); + SAVEFREESV(PL_compcv); + + SvREFCNT_inc_simple_void(PL_compcv); + + newATTRSUB( + sub_ix, + newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), + proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, + NULL, + NULL + ); + } + + if (builtin_attrs & MY_ATTR_LVALUE) { CvLVALUE_on(PL_compcv); } @@ -426,17 +498,55 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len /* munge */ { - /* create outer block: '{' */ - const int save_ix = S_block_start(aTHX_ TRUE); - OP *init = NULL; + OP *prelude = NULL; /* my $self = shift; */ if (SvTRUE(spec->shift)) { OP *const var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8)); var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); - init = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); - init = newSTATEOP(0, NULL, init); + prelude = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); + prelude = newSTATEOP(0, NULL, prelude); + } + + /* min/max argument count checks */ + if (spec->flags & FLAG_CHECK_NARGS) { + if (args_min > 0) { + OP *chk, *cond, *err, *croak; + + err = newSVOP(OP_CONST, 0, + newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator))); + + croak = newCVREF(OPf_WANT_SCALAR, + newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); + err = newUNOP(OP_ENTERSUB, OPf_STACKED, + op_append_elem(OP_LIST, err, croak)); + + cond = newBINOP(OP_LT, 0, + newAVREF(newGVOP(OP_GV, 0, PL_defgv)), + newSVOP(OP_CONST, 0, newSViv(args_min))); + chk = newLOGOP(OP_AND, 0, cond, err); + + prelude = op_append_list(OP_LINESEQ, prelude, newSTATEOP(0, NULL, chk)); + } + if (args_max != -1) { + OP *chk, *cond, *err, *croak; + + err = newSVOP(OP_CONST, 0, + newSVpvf("Too many arguments for %"SVf, SVfARG(declarator))); + + croak = newCVREF(OPf_WANT_SCALAR, + newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); + err = newUNOP(OP_ENTERSUB, OPf_STACKED, + op_append_elem(OP_LIST, err, croak)); + + cond = newBINOP(OP_GT, 0, + newAVREF(newGVOP(OP_GV, 0, PL_defgv)), + newSVOP(OP_CONST, 0, newSViv(args_max))); + chk = newLOGOP(OP_AND, 0, cond, err); + + prelude = op_append_list(OP_LINESEQ, prelude, newSTATEOP(0, NULL, chk)); + } } /* my (PARAMS) = @_; */ @@ -457,23 +567,54 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len init_param = newASSIGNOP(OPf_STACKED, left, 0, right); init_param = newSTATEOP(0, NULL, init_param); - init = op_append_list(OP_LINESEQ, init, init_param); + prelude = op_append_list(OP_LINESEQ, prelude, init_param); } - /* add '();' to make function return nothing by default */ - /* (otherwise the invisible parameter initialization can "leak" into - the return value: fun ($x) {}->("asdf", 0) == 2) */ - if (init) { - init = op_append_list(OP_LINESEQ, init, newSTATEOP(0, NULL, newOP(OP_STUB, OPf_PARENS))); + /* defaults */ + { + OP *gen = NULL; + DefaultParamSpec *dp; + + for (dp = defaults; dp; dp = dp->next) { + OP *init = dp->init; + OP *var, *args, *cond; + + /* var = `$,name */ + var = newOP(OP_PADSV, 0); + var->op_targ = pad_findmy_sv(dp->name, 0); + + /* init = `,var = ,init */ + init = newASSIGNOP(OPf_STACKED, var, 0, init); + + /* args = `@_ */ + args = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); + + /* cond = `,args < ,index */ + cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit))); + + /* init = `,init if ,cond */ + init = newLOGOP(OP_AND, 0, cond, init); + + /* gen = `,gen ; ,init */ + gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init)); + + dp->init = NULL; + } + + prelude = op_append_list(OP_LINESEQ, prelude, gen); } /* finally let perl parse the actual subroutine body */ body = parse_block(0); - body = op_append_list(OP_LINESEQ, init, body); + /* add '();' to make function return nothing by default */ + /* (otherwise the invisible parameter initialization can "leak" into + the return value: fun ($x) {}->("asdf", 0) == 2) */ + if (prelude) { + body = newSTATEOP(0, NULL, body); + } - /* close outer block: '}' */ - S_block_end(aTHX_ save_ix, body); + body = op_append_list(OP_LINESEQ, prelude, body); } /* it's go time. */ @@ -482,6 +623,9 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len *attrs_sentinel = NULL; SvREFCNT_inc_simple_void(PL_compcv); + /* close outer block: '}' */ + S_block_end(aTHX_ save_ix, body); + if (!saw_name) { *pop = newANONATTRSUB( floor_ix, @@ -505,7 +649,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len } static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { - Spec spec; + KWSpec spec; int ret; SAVETMPS; @@ -530,11 +674,12 @@ 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, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); + newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); + newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); + newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); - newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_)); + newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); /**/ diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 5a42344..e84c3de 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -5,14 +5,14 @@ use v5.14.0; use strict; use warnings; +use Carp qw(confess); + use XSLoader; BEGIN { our $VERSION = '0.06'; XSLoader::load; } -use Carp qw(confess); - sub _assert_valid_identifier { my ($name, $with_dollar) = @_; my $bonus = $with_dollar ? '\$' : ''; @@ -28,16 +28,24 @@ sub _assert_valid_attributes { my @bare_arms = qw(function method); my %type_map = ( - function => { name => 'optional' }, + function => { + name => 'optional', + default_arguments => 1, + check_argument_count => 0, + }, method => { name => 'optional', - shift => '$self', + default_arguments => 1, + check_argument_count => 0, attrs => ':method', + shift => '$self', }, classmethod => { name => 'optional', - shift => '$class', + default_arguments => 1, + check_argument_count => 0, attrs => ':method', + shift => '$class', }, ); @@ -83,6 +91,9 @@ sub import { $clean{attrs} = delete $type{attrs} || ''; _assert_valid_attributes $clean{attrs} if $clean{attrs}; + $clean{default_arguments} = !!delete $type{default_arguments}; + $clean{check_argument_count} = !!delete $type{check_argument_count}; + %type and confess "Invalid keyword property: @{[keys %type]}"; $spec{$name} = \%clean; @@ -91,13 +102,16 @@ sub import { for my $kw (keys %spec) { my $type = $spec{$kw}; + my $flags = + $type->{name} eq 'prohibited' ? FLAG_ANON_OK : + $type->{name} eq 'required' ? FLAG_NAME_OK : + FLAG_ANON_OK | FLAG_NAME_OK + ; + $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; + $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; + $^H{HINTK_FLAGS_ . $kw} = $flags; $^H{HINTK_SHIFT_ . $kw} = $type->{shift}; $^H{HINTK_ATTRS_ . $kw} = $type->{attrs}; - $^H{HINTK_NAME_ . $kw} = - $type->{name} eq 'prohibited' ? FLAG_NAME_PROHIBITED : - $type->{name} eq 'required' ? FLAG_NAME_REQUIRED : - FLAG_NAME_OPTIONAL - ; $^H{+HINTK_KEYWORDS} .= "$kw "; } } diff --git a/padop_on_crack.c.inc b/padop_on_crack.c.inc index 523b4ba..4f143b0 100644 --- a/padop_on_crack.c.inc +++ b/padop_on_crack.c.inc @@ -757,3 +757,293 @@ static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV } #endif + +#ifndef pad_findmy_sv + +#define pad_findmy_sv(SV, FLAGS) \ + S_pad_findmy(aTHX_ SvPV_nolen(SV), FLAGS) + +#define PARENT_PAD_INDEX_set(SV, VAL) \ + STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END +#define PARENT_FAKELEX_FLAGS_set(SV, VAL) \ + STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END + +static PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV *cv, U32 seq, int warn, SV **out_capture, SV **out_name_sv, int *out_flags) { +#define CvCOMPILED(CV) CvROOT(CV) +#define CvLATE(CV) (CvANON(CV) || SvTYPE(CV) == SVt_PVFM) + dVAR; + I32 offset, new_offset; + SV *new_capture; + SV **new_capturep; + const AV *const padlist = CvPADLIST(cv); + + *out_flags = 0; + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n", + PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" )); + + /* first, search this pad */ + + if (padlist) { /* not an undef CV */ + I32 fake_offset = 0; + const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]); + SV * const * const name_svp = AvARRAY(nameav); + + for (offset = AvFILLp(nameav); offset > 0; offset--) { + const SV * const namesv = name_svp[offset]; + if (namesv && namesv != &PL_sv_undef + && strEQ(SvPVX_const(namesv), name)) + { + if (SvFAKE(namesv)) { + fake_offset = offset; /* in case we don't find a real one */ + continue; + } + /* is seq within the range _LOW to _HIGH ? + * This is complicated by the fact that PL_cop_seqmax + * may have wrapped around at some point */ + if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO) + continue; /* not yet introduced */ + + if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) { + /* in compiling scope */ + if ( + (seq > COP_SEQ_RANGE_LOW(namesv)) + ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1)) + : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1)) + ) + break; + } + else if ( + (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv)) + ? + ( seq > COP_SEQ_RANGE_LOW(namesv) + || seq <= COP_SEQ_RANGE_HIGH(namesv)) + + : ( seq > COP_SEQ_RANGE_LOW(namesv) + && seq <= COP_SEQ_RANGE_HIGH(namesv)) + ) + break; + } + } + + if (offset > 0 || fake_offset > 0 ) { /* a match! */ + if (offset > 0) { /* not fake */ + fake_offset = 0; + *out_name_sv = name_svp[offset]; /* return the namesv */ + + /* set PAD_FAKELEX_MULTI if this lex can have multiple + * instances. For now, we just test !CvUNIQUE(cv), but + * ideally, we should detect my's declared within loops + * etc - this would allow a wider range of 'not stayed + * shared' warnings. We also treated already-compiled + * lexes as not multi as viewed from evals. */ + + *out_flags = CvANON(cv) ? + PAD_FAKELEX_ANON : + (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) + ? PAD_FAKELEX_MULTI : 0; + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n", + PTR2UV(cv), (long)offset, + (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv), + (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv))); + } + else { /* fake match */ + offset = fake_offset; + *out_name_sv = name_svp[offset]; /* return the namesv */ + *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n", + PTR2UV(cv), (long)offset, (unsigned long)*out_flags, + (unsigned long) PARENT_PAD_INDEX(*out_name_sv) + )); + } + + /* return the lex? */ + + if (out_capture) { + + /* our ? */ + if (SvPAD_OUR(*out_name_sv)) { + *out_capture = NULL; + return offset; + } + + /* trying to capture from an anon prototype? */ + if (CvCOMPILED(cv) + ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) + : *out_flags & PAD_FAKELEX_ANON) + { + if (warn) + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); + *out_capture = NULL; + } + + /* real value */ + else { + int newwarn = warn; + if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) + && !SvPAD_STATE(name_svp[offset]) + && warn && ckWARN(WARN_CLOSURE)) { + newwarn = 0; + Perl_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" will not stay shared", name); + } + + if (fake_offset && CvANON(cv) + && CvCLONE(cv) &&!CvCLONED(cv)) + { + SV *n; + /* not yet caught - look further up */ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n", + PTR2UV(cv))); + n = *out_name_sv; + (void)S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), + CvOUTSIDE_SEQ(cv), + newwarn, out_capture, out_name_sv, out_flags); + *out_name_sv = n; + return offset; + } + + *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[ + CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset]; + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n", + PTR2UV(cv), PTR2UV(*out_capture))); + + if (SvPADSTALE(*out_capture) + && !SvPAD_STATE(name_svp[offset])) + { + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); + *out_capture = NULL; + } + } + if (!*out_capture) { + if (*name == '@') + *out_capture = sv_2mortal(MUTABLE_SV(newAV())); + else if (*name == '%') + *out_capture = sv_2mortal(MUTABLE_SV(newHV())); + else + *out_capture = sv_newmortal(); + } + } + + return offset; + } + } + + /* it's not in this pad - try above */ + + if (!CvOUTSIDE(cv)) + return NOT_IN_PAD; + + /* out_capture non-null means caller wants us to capture lex; in + * addition we capture ourselves unless it's an ANON/format */ + new_capturep = out_capture ? out_capture : + CvLATE(cv) ? NULL : &new_capture; + + offset = S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, + new_capturep, out_name_sv, out_flags); + if ((PADOFFSET)offset == NOT_IN_PAD) + return NOT_IN_PAD; + + /* found in an outer CV. Add appropriate fake entry to this pad */ + + /* don't add new fake entries (via eval) to CVs that we have already + * finished compiling, or to undef CVs */ + if (CvCOMPILED(cv) || !padlist) + return 0; /* this dummy (and invalid) value isnt used by the caller */ + + { + /* This relies on sv_setsv_flags() upgrading the destination to the same + type as the source, independent of the flags set, and on it being + "good" and only copying flag bits and pointers that it understands. + */ + SV *new_namesv = newSVsv(*out_name_sv); + AV * const ocomppad_name = PL_comppad_name; + PAD * const ocomppad = PL_comppad; + PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]); + PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]); + PL_curpad = AvARRAY(PL_comppad); + + new_offset + = pad_add_name_sv(new_namesv, + 0, + SvPAD_TYPED(*out_name_sv) + ? SvSTASH(*out_name_sv) : NULL, + SvOURSTASH(*out_name_sv) + ); + + SvFAKE_on(new_namesv); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%.*s\" FAKE\n", + (long)new_offset, + (int) SvCUR(new_namesv), SvPVX(new_namesv))); + PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); + + PARENT_PAD_INDEX_set(new_namesv, 0); + if (SvPAD_OUR(new_namesv)) { + NOOP; /* do nothing */ + } + else if (CvLATE(cv)) { + /* delayed creation - just note the offset within parent pad */ + PARENT_PAD_INDEX_set(new_namesv, offset); + CvCLONE_on(cv); + } + else { + /* immediate creation - capture outer value right now */ + av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n", + PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); + } + *out_name_sv = new_namesv; + *out_flags = PARENT_FAKELEX_FLAGS(new_namesv); + + PL_comppad_name = ocomppad_name; + PL_comppad = ocomppad; + PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; + } + return new_offset; +#undef CvLATE +#undef CvCOMPILED +} + +static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) { + dVAR; + SV *out_sv; + int out_flags; + I32 offset; + const AV *nameav; + SV **name_svp; + + offset = S_pad_findlex(aTHX_ name, PL_compcv, PL_cop_seqmax, 1, + NULL, &out_sv, &out_flags); + if ((PADOFFSET)offset != NOT_IN_PAD) + return offset; + + /* look for an our that's being introduced; this allows + * our $foo = 0 unless defined $foo; + * to not give a warning. (Yes, this is a hack) */ + + nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]); + name_svp = AvARRAY(nameav); + for (offset = AvFILLp(nameav); offset > 0; offset--) { + const SV * const namesv = name_svp[offset]; + if (namesv && namesv != &PL_sv_undef + && !SvFAKE(namesv) + && (SvPAD_OUR(namesv)) + && strEQ(SvPVX_const(namesv), name) + && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO + ) + return offset; + } + return NOT_IN_PAD; +} + +#endif diff --git a/t/checkered.t b/t/checkered.t new file mode 100644 index 0000000..b0313d2 --- /dev/null +++ b/t/checkered.t @@ -0,0 +1,135 @@ +#!perl + +use Test::More tests => 108; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters { + fun => { + check_argument_count => 1, + default_arguments => 1, + }, + + sad => { + check_argument_count => 0, + }, +}; + +fun error_like($re, $body, $name = undef) { + local $@; + ok !eval { $body->(); 1 }; + like $@, $re, $name; +} + +fun foo_any { [@_] } +fun foo_any_a(@args) { [@args] } +fun foo_any_b($x = undef, @rest) { [@_] } +fun foo_0() { [@_] } +fun foo_1($x) { [@_] } +fun foo_2($x, $y) { [@_] } +fun foo_3($x, $y, $z) { [@_] } +fun foo_0_1($x = 'D0') { [$x] } +fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } +fun foo_0_3($x = 'D0', $y, $z = 'D2') { [$x, $y, $z] } +fun foo_1_2($x, $y = 'D1') { [$x, $y] } +fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } +fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } +fun foo_1_($x, @y) { [@_] } + +is_deeply foo_any, []; +is_deeply foo_any('a'), ['a']; +is_deeply foo_any('a', 'b'), ['a', 'b']; +is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; +is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; + +is_deeply foo_any_a, []; +is_deeply foo_any_a('a'), ['a']; +is_deeply foo_any_a('a', 'b'), ['a', 'b']; +is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; +is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; + +is_deeply foo_any_b, []; +is_deeply foo_any_b('a'), ['a']; +is_deeply foo_any_b('a', 'b'), ['a', 'b']; +is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; +is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; + +is_deeply foo_0, []; +error_like qr/Too many arguments.*foo_0/, fun { foo_0 'a' }; +error_like qr/Too many arguments.*foo_0/, fun { foo_0 'a', 'b' }; +error_like qr/Too many arguments.*foo_0/, fun { foo_0 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_0/, fun { foo_0 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_1/, fun { foo_1 }; +is_deeply foo_1('a'), ['a']; +error_like qr/Too many arguments.*foo_1/, fun { foo_1 'a', 'b' }; +error_like qr/Too many arguments.*foo_1/, fun { foo_1 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_1/, fun { foo_1 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_2/, fun { foo_2 }; +error_like qr/Not enough arguments.*foo_2/, fun { foo_2 'a' }; +is_deeply foo_2('a', 'b'), ['a', 'b']; +error_like qr/Too many arguments.*foo_2/, fun { foo_2 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_2/, fun { foo_2 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_3/, fun { foo_3 }; +error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a' }; +error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a', 'b' }; +is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; +error_like qr/Too many arguments.*foo_3/, fun { foo_3 'a', 'b', 'c', 'd' }; + +is_deeply foo_0_1, ['D0']; +is_deeply foo_0_1('a'), ['a']; +error_like qr/Too many arguments.*foo_0_1/, fun { foo_0_1 'a', 'b' }; +error_like qr/Too many arguments.*foo_0_1/, fun { foo_0_1 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_0_1/, fun { foo_0_1 'a', 'b', 'c', 'd' }; + +is_deeply foo_0_2, ['D0', 'D1']; +is_deeply foo_0_2('a'), ['a', 'D1']; +is_deeply foo_0_2('a', 'b'), ['a', 'b']; +error_like qr/Too many arguments.*foo_0_2/, fun { foo_0_2 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_0_2/, fun { foo_0_2 'a', 'b', 'c', 'd' }; + +is_deeply foo_0_3, ['D0', undef, 'D2']; +is_deeply foo_0_3('a'), ['a', undef, 'D2']; +is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; +is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; +error_like qr/Too many arguments.*foo_0_3/, fun { foo_0_3 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_1_2/, fun { foo_1_2 }; +is_deeply foo_1_2('a'), ['a', 'D1']; +is_deeply foo_1_2('a', 'b'), ['a', 'b']; +error_like qr/Too many arguments.*foo_1_2/, fun { foo_1_2 'a', 'b', 'c' }; +error_like qr/Too many arguments.*foo_1_2/, fun { foo_1_2 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_1_3/, fun { foo_1_3 }; +is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; +is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; +is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; +error_like qr/Too many arguments.*foo_1_3/, fun { foo_1_3 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 }; +error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 'a' }; +is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; +is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; +error_like qr/Too many arguments.*foo_2_3/, fun { foo_2_3 'a', 'b', 'c', 'd' }; + +error_like qr/Not enough arguments.*foo_1_/, fun { foo_1_ }; +is_deeply foo_1_('a'), ['a']; +is_deeply foo_1_('a', 'b'), ['a', 'b']; +is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; +is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; + + +sad puppy($eyes) { [@_] } +sad frog($will, $never) { $will * 3 + (pop) - $never } + +is_deeply puppy, []; +is_deeply puppy('a'), ['a']; +is_deeply puppy('a', 'b'), ['a', 'b']; +is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; +is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; + +is frog(7, 4, 1), 18; +is frog(7, 4), 21; diff --git a/t/defaults.t b/t/defaults.t new file mode 100644 index 0000000..dcac440 --- /dev/null +++ b/t/defaults.t @@ -0,0 +1,104 @@ +#!perl + +use Test::More tests => 38; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters { + fun => { + default_arguments => 1, + }, + + nofun => { + default_arguments => 0, + }, +}; + +fun foo0($x, $y = 1, $z = 3) { $x * 5 + $y * 2 + $z } + +is foo0(10), 55; +is foo0(5, -2), 24; +is foo0(6, 10, 1), 51; + +is fun ($answer = 42) { $answer }->(), 42; + +fun sharingan($input, $x = [], $y = {}) { + push @$x, $input; + $y->{$#$x} = $input; + $x, $y +} + +{ + is_deeply [sharingan 'e'], [['e'], {0 => 'e'}]; + my $sneaky = ['ants']; + is_deeply [sharingan $sneaky], [[['ants']], {0 => ['ants']}]; + unshift @$sneaky, 'thanks'; + is_deeply [sharingan $sneaky], [[['thanks', 'ants']], {0 => ['thanks', 'ants']}]; + @$sneaky = 'thants'; + is_deeply [sharingan $sneaky], [[['thants']], {0 => ['thants']}]; +} + +is eval('fun ($x, $y = $x) {}'), undef; +like $@, qr/^Global symbol.*explicit package name/; + +{ + my $d = 'outer'; + my $f; + { + my $d = 'herp'; + fun guy($d = $d, $x = $d . '2') { + return [$d, $x]; + } + + is_deeply guy('a', 'b'), ['a', 'b']; + is_deeply guy('c'), ['c', 'herp2']; + is_deeply guy, ['herp', 'herp2']; + + $d = 'ort'; + is_deeply guy('a', 'b'), ['a', 'b']; + is_deeply guy('c'), ['c', 'ort2']; + is_deeply guy, ['ort', 'ort2']; + + my $g = fun ($alarum = $d) { "[$alarum]" }; + is $g->(""), "[]"; + is $g->(), "[ort]"; + + $d = 'flowerpot'; + is_deeply guy('bloodstain'), ['bloodstain', 'flowerpot2']; + is $g->(), "[flowerpot]"; + + $f = $g; + } + + is $f->(), "[flowerpot]"; + is $f->("Q"), "[Q]"; +} + +{ + my $c = 0; + fun edelweiss($x = $c++) :(;$) { $x } +} + +is edelweiss "AAAAA", "AAAAA"; +is_deeply edelweiss [], []; +is edelweiss, 0; +is edelweiss, 1; +is_deeply edelweiss {}, {}; +is edelweiss 0, 0; +is edelweiss, 2; + +for my $f (fun ($wtf = return 'ohi') { "~$wtf" }) { + is $f->(""), "~"; + is $f->("a"), "~a"; + is $f->(), "ohi"; +} + +is eval('fun (@x = 42) {}'), undef; +like $@, qr/default value/; + +is eval('fun ($x, %y = ()) {}'), undef; +like $@, qr/default value/; + +is eval('nofun ($x = 42) {}'), undef; +like $@, qr/nofun.*unexpected.*=.*parameter/; diff --git a/t/defaults_regress.t b/t/defaults_regress.t new file mode 100644 index 0000000..a688ba2 --- /dev/null +++ b/t/defaults_regress.t @@ -0,0 +1,25 @@ +#!perl + +use Test::More tests => 3; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters { + fun => { + default_arguments => 1, + }, +}; + +{ + my ($d0, $d1, $d2, $d3); + my $default = 'aaa'; + + fun padness($x = $default++) { + return $x; + } + + is padness('unrelated'), 'unrelated'; + is &padness(), 'aaa'; + is padness, 'aab'; +}