Add support for copy magic on code prototype clone

This introduces the constant VMG_COMPAT_CODE_COPY_CLONE.

diff --git a/Magic.xs b/Magic.xs
index c199f7eb2e5847a3e411c4c9b32fe73f3a46073a..03363e1057916ede0fa519cd2ac56f38a681b8bb 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -187,6 +187,12 @@
 # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0
 #endif
 
+#if VMG_HAS_PERL(5, 17, 0)
+# define VMG_COMPAT_CODE_COPY_CLONE 1
+#else
+# define VMG_COMPAT_CODE_COPY_CLONE 0
+#endif
+
 #if VMG_HAS_PERL(5, 13, 2)
 # define VMG_COMPAT_GLOB_GET 1
 #else
@@ -1560,6 +1566,9 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_S
   keysv = newSVpvn(key, keylen);
  }
 
+ if (SvTYPE(sv) >= SVt_PVCV)
+  nsv = sv_2mortal(newRV_inc(nsv));
+
  ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
 
  if (keylen != HEf_SVKEY) {
@@ -1817,6 +1826,8 @@ BOOT:
                     newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
  newCONSTSUB(stash, "VMG_COMPAT_HASH_DELETE_NOUVAR_VOID",
                     newSVuv(VMG_COMPAT_HASH_DELETE_NOUVAR_VOID));
+ newCONSTSUB(stash, "VMG_COMPAT_CODE_COPY_CLONE",
+                    newSVuv(VMG_COMPAT_CODE_COPY_CLONE));
  newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET));
  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 38d35af4657129812cfe1cab79d76e3d83effcfc..a9e0732c5c388348860fe5493fdf5394f865db8f 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -152,7 +152,10 @@ It behaves roughly like Perl object destructors (i.e. C<DESTROY> methods), excep
 
 I<copy>
 
-This magic only applies to tied arrays and hashes, and fires when you try to access or change their elements.
+When applied to tied arrays and hashes, this magic fires when you try to access or change their elements.
+
+Starting from perl 5.17.0, it can also be applied to closure prototypes, in which case the magic will be called when the prototype is cloned.
+The L</VMG_COMPAT_CODE_COPY_CLONE> constant is true when your perl support this feature.
 
 =item *
 
@@ -269,8 +272,11 @@ The callback is expected to return the new scalar or array length to use, or C<u
 
 I<copy>
 
-C<$_[2]> is a either an alias or a copy of the current key, and C<$_[3]> is an alias to the current element (i.e. the value).
-Because C<$_[2]> might be a copy, it is useless to try to change it or cast magic on it.
+When the variable for which the magic is invoked is an array or an hash, C<$_[2]> is a either an alias or a copy of the current key, and C<$_[3]> is an alias to the current element (i.e. the value).
+Since C<$_[2]> might be a copy, it is useless to try to change it or cast magic on it.
+
+Starting from perl 5.17.0, this magic can also be called for code references.
+In this case, C<$_[2]> is always C<undef> and C<$_[3]> is a reference to the cloned anonymous subroutine.
 
 =item *
 
@@ -463,6 +469,10 @@ True for perls that call I<clear> magic when undefining magical arrays.
 
 True for perls that don't call I<delete> magic when you delete an element from a hash in void context.
 
+=head2 C<VMG_COMPAT_CODE_COPY_CLONE>
+
+True for perls that call I<copy> magic when a magical closure prototype is cloned.
+
 =head2 C<VMG_COMPAT_GLOB_GET>
 
 True for perls that call I<get> magic for operations on globs.
@@ -646,6 +656,7 @@ our %EXPORT_TAGS    = (
    VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
    VMG_COMPAT_ARRAY_UNDEF_CLEAR
    VMG_COMPAT_HASH_DELETE_NOUVAR_VOID
+   VMG_COMPAT_CODE_COPY_CLONE
    VMG_COMPAT_GLOB_GET
    VMG_PERL_PATCHLEVEL
    VMG_THREADSAFE VMG_FORKSAFE

diff --git a/t/01-import.t b/t/01-import.t
index f6d41d081f24e820894ee3c02943cb5f5d91a011..099ff317be46861531683b3f640e6b934d43c6ef 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 21;
+use Test::More tests => 2 * 22;
 
 require Variable::Magic;
 
@@ -20,6 +20,7 @@ my %syms = (
   VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
   VMG_COMPAT_ARRAY_UNDEF_CLEAR
   VMG_COMPAT_HASH_DELETE_NOUVAR_VOID
+  VMG_COMPAT_CODE_COPY_CLONE
   VMG_COMPAT_GLOB_GET
   VMG_PERL_PATCHLEVEL
   VMG_THREADSAFE VMG_FORKSAFE

diff --git a/t/25-copy.t b/t/25-copy.t
index 394449541b3ab123f7ff015b0bf16834ab77c3a1..46e324141653d2298c32b85ad5a3b4ce948e379e 100644 (file)
--- a/t/25-copy.t
+++ b/t/25-copy.t
@@ -8,9 +8,9 @@ use Test::More;
 use lib 't/lib';
 use VPIT::TestHelpers;
 
-use Variable::Magic qw<cast dispell>;
+use Variable::Magic qw<wizard cast dispell VMG_COMPAT_CODE_COPY_CLONE>;
 
-plan tests => 2 + ((2 * 5 + 3) + (2 * 2 + 1)) + (2 * 9 + 6) + 1;
+plan tests => 2 + ((2 * 5 + 3) + (2 * 2 + 1)) + (2 * 9 + 6) + 3 + 1;
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
@@ -80,3 +80,23 @@ SKIP: {
 
  watch { undef %h } { }, 'tied hash undef';
 }
+
+SKIP: {
+ skip 'copy magic not called for cloned prototypes before perl 5.17.0' => 3
+                                              unless VMG_COMPAT_CODE_COPY_CLONE;
+ my $w = wizard copy => sub {
+  is ref($_[0]), 'CODE', 'first arg in copy on clone is a code ref';
+  is $_[2],      undef,  'third arg in copy on clone is undef';
+  is ref($_[3]), 'CODE', 'fourth arg in copy on clone is a code ref';
+ };
+ eval <<'TEST_COPY';
+  package X;
+  sub MODIFY_CODE_ATTRIBUTES {
+   my ($pkg, $sub) = @_;
+   &Variable::Magic::cast($sub, $w);
+   return;
+  }
+  my $i;
+  my $f = sub : Hello { $i };
+TEST_COPY
+}