From: Lukas Mai Date: Sun, 15 Sep 2013 22:47:34 +0000 (+0200) Subject: implement 'runtime' keyword attribute X-Git-Tag: v1.0301~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=42e595b0d7841bfda100f6af7115ea41cc46b818;p=p5sagit%2FFunction-Parameters.git implement 'runtime' keyword attribute --- diff --git a/MANIFEST b/MANIFEST index 5039570..468319b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -88,6 +88,8 @@ t/invocant.t 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 diff --git a/Parameters.xs b/Parameters.xs index 4a44068..3cf607b 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -90,14 +90,15 @@ WARNINGS_ENABLE #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) { @@ -1411,7 +1412,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } /* 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); @@ -1915,6 +1916,7 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL /* it's go time. */ { + int runtime = spec->flags & FLAG_RUNTIME; CV *cv; OP *const attrs = op_guard_relinquish(attrs_sentinel); @@ -1925,8 +1927,8 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL 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 ); @@ -1936,7 +1938,25 @@ static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRL } 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; } @@ -2047,6 +2067,27 @@ static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **o 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_ @@ -2054,7 +2095,7 @@ PROTOTYPES: ENABLE UV fp__cv_root(sv) - SV * sv + SV *sv PREINIT: CV *xcv; HV *hv; @@ -2065,6 +2106,32 @@ fp__cv_root(sv) 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); @@ -2077,6 +2144,7 @@ WARNINGS_ENABLE { 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_)); diff --git a/lib/Function/Parameters.pm b/lib/Function/Parameters.pm index 018faf9..a39f93b 100644 --- a/lib/Function/Parameters.pm +++ b/lib/Function/Parameters.pm @@ -147,6 +147,7 @@ sub import { $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}; @@ -188,6 +189,7 @@ sub import { $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}; @@ -265,9 +267,9 @@ sub info { 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}') ) } @@ -389,11 +391,12 @@ This is just a normal block of statements, as with L|perlsub>. No surpris =head3 Name If present, it specifies the name of the function being defined. As with -L|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|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 flag below). If no name is present, the +declaration is an expression that evaluates to a reference to the function in +question. =head3 Attributes @@ -626,6 +629,21 @@ Valid values: C (default), C (all functions defined with this keyword must have a name), and C (functions defined with this keyword must be anonymous). +=item C + +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 has been reached at runtime. + +B A future version of this module may enable C<< runtime => 1 >> by +default for methods. + =item C Valid values: strings that look like scalar variables. This lets you specify a @@ -694,6 +712,7 @@ The predefined type C is equivalent to: default_arguments => 1, strict => 0, invocant => 0, + runtime => 0, } These are all default values, so C is also equivalent to C<{}>. @@ -705,6 +724,7 @@ C is equivalent to: attributes => ':method', shift => '$self', invocant => 1, + # runtime => 1, ## possibly in a future version of this module } @@ -812,6 +832,12 @@ generated code corresponds to: # ... 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 diff --git a/t/method_cache.t b/t/method_cache.t new file mode 100644 index 0000000..42db3b1 --- /dev/null +++ b/t/method_cache.t @@ -0,0 +1,20 @@ +#!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'; diff --git a/t/method_runtime.t b/t/method_runtime.t new file mode 100644 index 0000000..9064a92 --- /dev/null +++ b/t/method_runtime.t @@ -0,0 +1,77 @@ +#!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'), '$;$';