From: Vincent Pit Date: Mon, 22 Sep 2014 17:07:25 +0000 (+0200) Subject: Add support for copy magic on code prototype clone X-Git-Tag: rt90205^0 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=9ad970e109ea4caa9767db1bda9d475444920c7a;p=perl%2Fmodules%2FVariable-Magic.git 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 c199f7e..03363e1 100644 --- 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 38d35af..a9e0732 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -152,7 +152,10 @@ It behaves roughly like Perl object destructors (i.e. C methods), excep I -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 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 -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 and C<$_[3]> is a reference to the cloned anonymous subroutine. =item * @@ -463,6 +469,10 @@ True for perls that call I magic when undefining magical arrays. True for perls that don't call I magic when you delete an element from a hash in void context. +=head2 C + +True for perls that call I magic when a magical closure prototype is cloned. + =head2 C True for perls that call I 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 f6d41d0..099ff31 100644 --- 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 3944495..46e3241 100644 --- 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; +use Variable::Magic qw; -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 +}