Copy call checker when cloning closure prototype
authorFather Chrysostomos <sprout@cpan.org>
Tue, 24 Apr 2012 03:29:13 +0000 (20:29 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 21 May 2012 23:51:34 +0000 (16:51 -0700)
Otherwise cv_set_call_checker has no effect inside an attribute han-
dler for a closure.

embed.fnc
embed.h
ext/XS-APItest/t/call_checker.t
mg.c
mg_raw.h
mg_vtable.h
op.c
pad.c
pod/perlguts.pod
proto.h
regen/mg_vtable.pl

index 9546555..5379121 100644 (file)
--- 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 f7db1e0..f6c4bad 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index 51dbc93..429cea6 100644 (file)
@@ -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 (file)
--- 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
index f4e1742..2a919b9 100644 (file)
--- 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 */" },
index 12f2fa3..e1622b2 100644 (file)
@@ -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 cf1e9a9..7fcac65 100644 (file)
--- a/op.c
+++ b/op.c
@@ -9618,6 +9618,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 (file)
--- 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);
 
index 908fa1f..b514556 100644 (file)
@@ -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 143eee0..eab2626 100644 (file)
--- 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)
index 605846b..f49471b 100644 (file)
@@ -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 {