Copy call checker when cloning closure prototype

Otherwise cv_set_call_checker has no effect inside an attribute han-
dler for a closure.

11 files changed, 52 insertions, 4 deletions

diff --git a/embed.fnc b/embed.fnc
index 95465555a8..537912167c 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 f7db1e0613..f6c4bad353 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 51dbc939a4..429cea6b9b 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 e202d585d3..03500da7ca 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 f4e174247b..2a919b99a3 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 12f2fa35f3..e1622b20a5 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 cf1e9a95ea..7fcac65994 100644
--- 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 c4362af0d4..3b8cac2203 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 908fa1f0bd..b5145560dd 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 143eee0e3e..eab2626584 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 605846bec6..f49471bf2b 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 {