#include <string.h>
+
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))))))
#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(""));
} \
} 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);
#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);
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;
/* 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) {
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);
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);
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));
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);
}
}
- /* 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] == ':') {
}
/* 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);
}
/* 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) = @_; */
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. */
*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,
}
static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
- Spec spec;
+ KWSpec spec;
int ret;
SAVETMPS;
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_));
/**/
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 ? '\$' : '';
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',
},
);
$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;
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 ";
}
}
}
#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
--- /dev/null
+#!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;
--- /dev/null
+#!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/;
--- /dev/null
+#!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';
+}
projects / p5sagit/Function-Parameters.git / commitdiff