t/lexical.t
t/lineno-torture.t
t/lineno.t
+t/method_cache.t
+t/method_runtime.t
t/name.t
t/name_1.fail
t/name_2.fail
#define DEFSTRUCT(T) typedef struct T T; struct T
enum {
- FLAG_NAME_OK = 0x01,
- FLAG_ANON_OK = 0x02,
- FLAG_DEFAULT_ARGS = 0x04,
- FLAG_CHECK_NARGS = 0x08,
- FLAG_INVOCANT = 0x10,
- FLAG_NAMED_PARAMS = 0x20,
- FLAG_TYPES_OK = 0x40,
- FLAG_CHECK_TARGS = 0x80
+ FLAG_NAME_OK = 0x001,
+ FLAG_ANON_OK = 0x002,
+ FLAG_DEFAULT_ARGS = 0x004,
+ FLAG_CHECK_NARGS = 0x008,
+ FLAG_INVOCANT = 0x010,
+ FLAG_NAMED_PARAMS = 0x020,
+ FLAG_TYPES_OK = 0x040,
+ FLAG_CHECK_TARGS = 0x080,
+ FLAG_RUNTIME = 0x100
};
DEFSTRUCT(KWSpec) {
}
/* surprise predeclaration! */
- if (saw_name) {
+ if (saw_name && !(spec->flags & FLAG_RUNTIME)) {
/* 'sub NAME (PROTO);' to make name/proto known to perl before it
starts parsing the body */
const I32 sub_ix = start_subparse(FALSE, 0);
/* it's go time. */
{
+ int runtime = spec->flags & FLAG_RUNTIME;
CV *cv;
OP *const attrs = op_guard_relinquish(attrs_sentinel);
cv = newATTRSUB(
floor_ix,
- saw_name ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL,
- proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
+ saw_name && !runtime ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL,
+ proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
attrs,
body
);
}
if (saw_name) {
- *pop = newOP(OP_NULL, 0);
+ if (!runtime) {
+ *pop = newOP(OP_NULL, 0);
+ } else {
+ *pop = newUNOP(
+ OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(
+ OP_LIST,
+ op_append_elem(
+ OP_LIST,
+ mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)),
+ newUNOP(
+ OP_REFGEN, 0,
+ newSVOP(OP_ANONCODE, 0, (SV *)cv)
+ )
+ ),
+ newCVREF(0, newGVOP(OP_GV, 0, gv_fetchpvs(MY_PKG "::_defun", 0, SVt_PVCV)))
+ )
+ );
+ }
return KEYWORD_PLUGIN_STMT;
}
return ret;
}
+#ifndef SvREFCNT_dec_NN
+#define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV)
+#endif
+
+#ifndef assert_
+#ifdef DEBUGGING
+#define assert_(X) assert(X),
+#else
+#define assert_(X)
+#endif
+#endif
+
+#ifndef gv_method_changed
+#define gv_method_changed(GV) ( \
+ assert_(isGV_with_GP(GV)) \
+ GvREFCNT(GV) > 1 \
+ ? (void)PL_sub_generation++ \
+ : mro_method_changed_in(GvSTASH(GV)) \
+)
+#endif
+
WARNINGS_RESET
MODULE = Function::Parameters PACKAGE = Function::Parameters PREFIX = fp_
UV
fp__cv_root(sv)
- SV * sv
+ SV *sv
PREINIT:
CV *xcv;
HV *hv;
OUTPUT:
RETVAL
+void
+fp__defun(name, body)
+ SV *name
+ CV *body
+ PREINIT:
+ GV *gv;
+ CV *xcv;
+ CODE:
+ assert(SvTYPE(body) == SVt_PVCV);
+ gv = gv_fetchsv(name, GV_ADDMULTI, SVt_PVCV);
+ xcv = GvCV(gv);
+ if (xcv) {
+ if (!GvCVGEN(gv) && (CvROOT(xcv) || CvXSUB(xcv)) && ckWARN(WARN_REDEFINE)) {
+ warner(packWARN(WARN_REDEFINE), "Subroutine %"SVf" redefined", SVfARG(name));
+ }
+ SvREFCNT_dec_NN(xcv);
+ }
+ GvCVGEN(gv) = 0;
+ GvASSUMECV_on(gv);
+ if (GvSTASH(gv)) {
+ gv_method_changed(gv);
+ }
+ GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(body));
+ CvGV_set(body, gv);
+ CvANON_off(body);
+
BOOT:
WARNINGS_ENABLE {
HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
newCONSTSUB(stash, "FLAG_TYPES_OK", newSViv(FLAG_TYPES_OK));
newCONSTSUB(stash, "FLAG_CHECK_TARGS", newSViv(FLAG_CHECK_TARGS));
+ newCONSTSUB(stash, "FLAG_RUNTIME", newSViv(FLAG_RUNTIME));
newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
$clean{types} = _delete_default \%type, 'types', 1;
$clean{invocant} = _delete_default \%type, 'invocant', 0;
+ $clean{runtime} = _delete_default \%type, 'runtime', 0;
$clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 0;
$clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 0;
$clean{check_argument_count} = $clean{check_argument_types} = 1 if delete $type{strict};
$flags |= FLAG_INVOCANT if $type->{invocant};
$flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
$flags |= FLAG_TYPES_OK if $type->{types};
+ $flags |= FLAG_RUNTIME if $type->{runtime};
$^H{HINTK_FLAGS_ . $kw} = $flags;
$^H{HINTK_SHIFT_ . $kw} = $type->{shift};
$^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
my $info = $metadata{$key} or return undef;
require Function::Parameters::Info;
Function::Parameters::Info->new(
- keyword => $info->{declarator},
+ keyword => $info->{declarator},
invocant => _mkparam1($info->{invocant}),
- slurpy => _mkparam1($info->{slurpy}),
+ slurpy => _mkparam1($info->{slurpy}),
(map +("_$_" => _mkparams @{$info->{$_}}), glob '{positional,named}_{required,optional}')
)
}
=head3 Name
If present, it specifies the name of the function being defined. As with
-L<C<sub>|perlsub>, if a name is present, the whole declaration is syntactically
-a statement and its effects are performed at compile time (i.e. at runtime you
-can call functions whose definitions only occur later in the file). If no name
-is present, the declaration is an expression that evaluates to a reference to
-the function in question. No surprises here either.
+L<C<sub>|perlsub>, if a name is present, by default the whole declaration is
+syntactically a statement and its effects are performed at compile time (i.e.
+at runtime you can call functions whose definitions only occur later in the
+file - but see the C<runtime> flag below). If no name is present, the
+declaration is an expression that evaluates to a reference to the function in
+question.
=head3 Attributes
this keyword must have a name), and C<prohibited> (functions defined with this
keyword must be anonymous).
+=item C<runtime>
+
+Valid values: booleans. If enabled, this keyword takes effect at runtime, not
+compile time:
+
+ use Function::Parameters { fun => { defaults => 'function_strict', runtime => 1 } };
+ say defined &foo ? "defined" : "not defined"; # not defined
+ fun foo() {}
+ say defined &foo ? "defined" : "not defined"; # defined
+
+C<&foo> is only defined after C<fun foo() {}> has been reached at runtime.
+
+B<CAVEAT:> A future version of this module may enable C<< runtime => 1 >> by
+default for methods.
+
=item C<shift>
Valid values: strings that look like scalar variables. This lets you specify a
default_arguments => 1,
strict => 0,
invocant => 0,
+ runtime => 0,
}
These are all default values, so C<function> is also equivalent to C<{}>.
attributes => ':method',
shift => '$self',
invocant => 1,
+ # runtime => 1, ## possibly in a future version of this module
}
# ... turns into ...
sub bar :method { my $self = shift; my ($x, $y, @z) = @_; sub bar; ... }
+=head1 BUGS AND INCOMPATIBILITIES
+
+A future version of this module may enable C<< runtime => 1 >> by default for
+methods. If this would break your code, please send me a note or file a bug on
+RT.
+
=head1 SUPPORT AND DOCUMENTATION
After installing, you can find documentation for this module with the
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+no warnings qw(once redefine);
+use strict;
+
+use Test::More tests => 2;
+
+use Function::Parameters {
+ method => { defaults => 'method_strict', runtime => 1 },
+};
+
+# See commit 978a498e17ec54b6f1fc65f3375a62a68f321f99 in perl
+
+method Y::b() { 'b' }
+*X::b = *Y::b;
+@Z::ISA = 'X';
+is +Z->b, 'b';
+
+method Y::b() { 'c' }
+is +Z->b, 'c';
--- /dev/null
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+use Test::More tests => 29;
+
+use Function::Parameters {
+ fun => 'function_strict',
+ method => { defaults => 'method_strict', runtime => 1 },
+};
+
+{
+ package Foo;
+
+ ::ok !defined &f1;
+ method f1() {}
+ ::ok defined &f1;
+
+ ::ok !defined &f2;
+ ::ok !defined &Bar::f2;
+ method Bar::f2() {}
+ ::ok !defined &f2;
+ ::ok defined &Bar::f2;
+
+ ::ok !defined &f3;
+ if (@ARGV < 0) { method f3() {} }
+ ::ok !defined &f3;
+}
+
+fun g1() { (caller 0)[3] }
+method g2() { (caller 0)[3] }
+fun Bar::g1() { (caller 0)[3] }
+method Bar::g2() { (caller 0)[3] }
+
+is g1, 'main::g1';
+is 'main'->g2, 'main::g2';
+is Bar::g1, 'Bar::g1';
+is 'Bar'->g2, 'Bar::g2';
+
+use Function::Parameters { fun_r => { defaults => 'function_strict', runtime => 1 } };
+
+{
+ package Foo_r;
+
+ ::ok !defined &f1;
+ fun_r f1() {}
+ ::ok defined &f1;
+
+ ::ok !defined &f2;
+ ::ok !defined &Bar_r::f2;
+ fun_r Bar_r::f2() {}
+ ::ok !defined &f2;
+ ::ok defined &Bar_r::f2;
+
+ ::ok !defined &f3;
+ if (@ARGV < 0) { fun_r f3() {} }
+ ::ok !defined &f3;
+}
+
+fun h1() { (caller 0)[3] }
+fun_r h2() { (caller 0)[3] }
+fun Bar::h1() { (caller 0)[3] }
+fun_r Bar::h2() { (caller 0)[3] }
+
+is h1, 'main::h1';
+is h2(), 'main::h2';
+is Bar::h1, 'Bar::h1';
+is Bar::h2(), 'Bar::h2';
+
+fun_r p1($x, $y) :($$) {}
+is prototype(\&p1), '$$';
+is prototype('p1'), '$$';
+is prototype('main::p1'), '$$';
+
+fun_r Bar::p2($x, $y = 0) :($;$) {}
+is prototype(\&Bar::p2), '$;$';
+is prototype('Bar::p2'), '$;$';
projects / p5sagit/Function-Parameters.git / commitdiff