In perl.git, the branch sprout/misc-post-5.16 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/1113300ec530d47e169f3d8c47155a127f9c5c60?hp=82188168ad52a980401f741409976037f1192835>
- Log ----------------------------------------------------------------- commit 1113300ec530d47e169f3d8c47155a127f9c5c60 Author: Father Chrysostomos <[email protected]> Date: Mon Apr 23 20:29:13 2012 -0700 Copy call checker when cloning closure prototype Otherwise cv_set_call_checker has no effect inside an attribute han- dler for a closure. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 ++ embed.h | 1 + ext/XS-APItest/t/call_checker.t | 13 ++++++++++++- mg.c | 19 +++++++++++++++++++ mg_raw.h | 2 +- mg_vtable.h | 4 ++++ op.c | 1 + pad.c | 2 ++ pod/perlguts.pod | 2 +- proto.h | 7 +++++++ regen/mg_vtable.pl | 3 ++- 11 files changed, 52 insertions(+), 4 deletions(-) diff --git a/embed.fnc b/embed.fnc index ab2b2f8..dc80d76 100644 --- a/embed.fnc +++ b/embed.fnc @@ -731,6 +731,8 @@ dp |int |magic_clearhints|NN SV* sv|NN MAGIC* mg p |int |magic_clearisa |NULLOK SV* sv|NN MAGIC* mg p |int |magic_clearpack|NN SV* sv|NN MAGIC* mg p |int |magic_clearsig |NN SV* sv|NN MAGIC* mg +p |int |magic_copycallchecker|NN SV* sv|NN MAGIC *mg|NN SV *nsv \ + |NULLOK const char *name|I32 namlen p |int |magic_existspack|NN SV* sv|NN const MAGIC* mg p |int |magic_freeovrld|NN SV* sv|NN MAGIC* mg p |int |magic_get |NN SV* sv|NN MAGIC* mg diff --git a/embed.h b/embed.h index 41e692c..d1f45fe 100644 --- a/embed.h +++ b/embed.h @@ -1105,6 +1105,7 @@ #define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b) #define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b) #define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b) +#define magic_copycallchecker(a,b,c,d,e) Perl_magic_copycallchecker(aTHX_ a,b,c,d,e) #define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b) #define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b) #define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b) diff --git a/ext/XS-APItest/t/call_checker.t b/ext/XS-APItest/t/call_checker.t index 51dbc93..429cea6 100644 --- a/ext/XS-APItest/t/call_checker.t +++ b/ext/XS-APItest/t/call_checker.t @@ -1,6 +1,6 @@ use warnings; use strict; -use Test::More tests => 64; +use Test::More tests => 67; use XS::APItest; @@ -158,4 +158,15 @@ is $@, ""; is_deeply $foo_got, undef; is $foo_ret, 9; +sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () } +BEGIN { + *foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; }; +} + +$foo_got = undef; +eval q{$foo_ret = foo2(@b, @c);}; +is $@, ""; +is_deeply $foo_got, [ qw(a b), qw(a b c) ]; +is $foo_ret, "z"; + 1; diff --git a/mg.c b/mg.c index e202d58..03500da 100644 --- a/mg.c +++ b/mg.c @@ -3383,6 +3383,25 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) return 0; } +int +Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, + const char *name, I32 namlen) +{ + MAGIC *nmg; + + PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; + PERL_UNUSED_ARG(name); + PERL_UNUSED_ARG(namlen); + + sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); + nmg = mg_find(nsv, mg->mg_type); + if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); + nmg->mg_ptr = mg->mg_ptr; + nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); + nmg->mg_flags |= MGf_REFCOUNTED; + return 1; +} + /* * Local variables: * c-indentation-style: bsd diff --git a/mg_raw.h b/mg_raw.h index f4e1742..2a919b9 100644 --- a/mg_raw.h +++ b/mg_raw.h @@ -84,7 +84,7 @@ "/* substr 'x' substr() lvalue */" }, { 'y', "want_vtbl_defelem | PERL_MAGIC_VALUE_MAGIC", "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" }, - { ']', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC", + { ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC", "/* checkcall ']' inlining/mutation of call to this CV */" }, { '~', "magic_vtable_max", "/* ext '~' Available for use by extensions */" }, diff --git a/mg_vtable.h b/mg_vtable.h index 12f2fa3..e1622b2 100644 --- a/mg_vtable.h +++ b/mg_vtable.h @@ -65,6 +65,7 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_arylen, want_vtbl_arylen_p, want_vtbl_backref, + want_vtbl_checkcall, want_vtbl_collxfrm, want_vtbl_dbline, want_vtbl_defelem, @@ -101,6 +102,7 @@ EXTCONST char *PL_magic_vtable_names[magic_vtable_max] = { "arylen", "arylen_p", "backref", + "checkcall", "collxfrm", "dbline", "defelem", @@ -156,6 +158,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = { { (int (*)(pTHX_ SV *, MAGIC *))Perl_magic_getarylen, Perl_magic_setarylen, 0, 0, 0, 0, 0, 0 }, { 0, 0, 0, 0, Perl_magic_freearylen_p, 0, 0, 0 }, { 0, 0, 0, 0, Perl_magic_killbackrefs, 0, 0, 0 }, + { 0, 0, 0, 0, 0, Perl_magic_copycallchecker, 0, 0 }, #ifdef USE_LOCALE_COLLATE { 0, Perl_magic_setcollxfrm, 0, 0, 0, 0, 0, 0 }, #else @@ -204,6 +207,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max]; #define PL_vtbl_arylen_p PL_magic_vtables[want_vtbl_arylen_p] #define PL_vtbl_backref PL_magic_vtables[want_vtbl_backref] #define PL_vtbl_bm PL_magic_vtables[want_vtbl_bm] +#define PL_vtbl_checkcall PL_magic_vtables[want_vtbl_checkcall] #define PL_vtbl_collxfrm PL_magic_vtables[want_vtbl_collxfrm] #define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline] #define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem] diff --git a/op.c b/op.c index 7cf012a..372c317 100644 --- a/op.c +++ b/op.c @@ -9617,6 +9617,7 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } + callmg->mg_flags |= MGf_COPY; } } diff --git a/pad.c b/pad.c index c4362af..3b8cac2 100644 --- a/pad.c +++ b/pad.c @@ -1912,6 +1912,8 @@ Perl_cv_clone(pTHX_ CV *proto) if (SvPOK(proto)) sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); + if (SvMAGIC(proto)) + mg_copy((SV *)proto, (SV *)cv, 0, 0); CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 908fa1f..b514556 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1105,7 +1105,7 @@ will be lost. y PERL_MAGIC_defelem vtbl_defelem Shadow "foreach" iterator variable / smart parameter vivification - ] PERL_MAGIC_checkcall (none) inlining/mutation of call + ] PERL_MAGIC_checkcall vtbl_checkcall inlining/mutation of call to this CV ~ PERL_MAGIC_ext (none) Available for use by extensions diff --git a/proto.h b/proto.h index 11a7d1b..013401c 100644 --- a/proto.h +++ b/proto.h @@ -2060,6 +2060,13 @@ PERL_CALLCONV int Perl_magic_clearsig(pTHX_ SV* sv, MAGIC* mg) #define PERL_ARGS_ASSERT_MAGIC_CLEARSIG \ assert(sv); assert(mg) +PERL_CALLCONV int Perl_magic_copycallchecker(pTHX_ SV* sv, MAGIC *mg, SV *nsv, const char *name, I32 namlen) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER \ + assert(sv); assert(mg); assert(nsv) + PERL_CALLCONV void Perl_magic_dump(pTHX_ const MAGIC *mg); PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, const MAGIC* mg) __attribute__nonnull__(pTHX_1) diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl index 605846b..f49471b 100644 --- a/regen/mg_vtable.pl +++ b/regen/mg_vtable.pl @@ -105,7 +105,7 @@ my %mg = arylen_p => { char => '@', value_magic => 1, desc => 'to move arylen out of XPVAV' }, ext => { char => '~', desc => 'Available for use by extensions' }, - checkcall => { char => ']', value_magic => 1, + checkcall => { char => ']', value_magic => 1, vtable => 'checkcall', desc => 'inlining/mutation of call to this CV'}, ); @@ -145,6 +145,7 @@ my %sig = 'hintselem' => {set => 'sethint', clear => 'clearhint'}, 'hints' => {clear => 'clearhints'}, 'vstring' => {set => 'setvstring'}, + 'checkcall' => {copy => 'copycallchecker'}, ); my ($vt, $raw, $names) = map { -- Perl5 Master Repository
