From: Vincent Pit Date: Fri, 17 Feb 2012 18:16:16 +0000 (+0100) Subject: Allow passing ref-to-undef as callbacks to install a noop callback X-Git-Tag: v0.48~4 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=f7f52ae0225ab0bf6304c21f5c8f53b2e9307bfa Allow passing ref-to-undef as callbacks to install a noop callback --- diff --git a/Magic.xs b/Magic.xs index c8de430..2829b9d 100644 --- a/Magic.xs +++ b/Magic.xs @@ -1074,18 +1074,26 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { #define vmg_cb_call3(I, OI, S, A1, A2, A3) \ vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3)) +STATIC int vmg_svt_default_noop(pTHX_ SV *sv, MAGIC *mg) { + return 0; +} + STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj); } +#define vmg_svt_get_noop vmg_svt_default_noop + STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj); } +#define vmg_svt_set_noop vmg_svt_default_noop + STATIC U32 vmg_sv_len(pTHX_ SV *sv) { #define vmg_sv_len(S) vmg_sv_len(aTHX_ (S)) STRLEN len; @@ -1143,12 +1151,27 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { return ret; } +STATIC U32 vmg_svt_len_noop(pTHX_ SV *sv, MAGIC *mg) { + U32 len = 0; + svtype t = SvTYPE(sv); + + if (t < SVt_PVAV) { + len = vmg_sv_len(sv); + } else if (t == SVt_PVAV) { + len = (U32) av_len((AV *) sv); + } + + return len; +} + STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj); } +#define vmg_svt_clear_noop vmg_svt_default_noop + STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w; int ret = 0; @@ -1204,6 +1227,8 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { return ret; } +#define vmg_svt_free_noop vmg_svt_default_noop + #if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0) # define VMG_SVT_COPY_KEYLEN_TYPE I32 #else @@ -1230,18 +1255,27 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_S return ret; } +STATIC int vmg_svt_copy_noop(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) { + return 0; +} + #if 0 STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { return 0; } +#define vmg_svt_dup_noop vmg_svt_dup #endif #if MGf_LOCAL + STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj); } + +#define vmg_svt_local_noop vmg_svt_default_noop + #endif /* MGf_LOCAL */ #if VMG_UVAR @@ -1339,19 +1373,46 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { /* --- Macros for the XS section ------------------------------------------- */ -#define VMG_SET_CB(S, N) \ - cb = (S); \ - w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? SvREFCNT_inc(SvRV(cb)) : NULL; - -#define VMG_SET_SVT_CB(S, N) \ - cb = (S); \ - if (SvOK(cb) && SvROK(cb)) { \ - t->svt_ ## N = vmg_svt_ ## N; \ - w->cb_ ## N = SvREFCNT_inc(SvRV(cb)); \ - } else { \ - t->svt_ ## N = NULL; \ - w->cb_ ## N = NULL; \ - } +#ifdef CvISXSUB +# define VMG_CVOK(C) \ + ((CvISXSUB(C) ? (void *) CvXSUB(C) : (void *) CvROOT(C)) ? 1 : 0) +#else +# define VMG_CVOK(C) (CvROOT(C) || CvXSUB(C)) +#endif + +#define VMG_CBOK(S) ((SvTYPE(S) == SVt_PVCV) ? VMG_CVOK(S) : SvOK(S)) + +#define VMG_SET_CB(S, N) { \ + SV *cb = (S); \ + if (SvOK(cb) && SvROK(cb)) { \ + cb = SvRV(cb); \ + if (VMG_CBOK(cb)) \ + SvREFCNT_inc_simple_void(cb); \ + else \ + cb = NULL; \ + } else { \ + cb = NULL; \ + } \ + w->cb_ ## N = cb; \ +} + +#define VMG_SET_SVT_CB(S, N) { \ + SV *cb = (S); \ + if (SvOK(cb) && SvROK(cb)) { \ + cb = SvRV(cb); \ + if (VMG_CBOK(cb)) { \ + t->svt_ ## N = vmg_svt_ ## N; \ + SvREFCNT_inc_simple_void(cb); \ + } else { \ + t->svt_ ## N = vmg_svt_ ## N ## _noop; \ + cb = NULL; \ + } \ + } else { \ + t->svt_ ## N = NULL; \ + cb = NULL; \ + } \ + w->cb_ ## N = cb; \ +} /* --- XS ------------------------------------------------------------------ */ @@ -1427,7 +1488,7 @@ PROTOTYPE: DISABLE PREINIT: vmg_wizard *w; MGVTBL *t; - SV *cb, *op_info, *copy_key; + SV *op_info, *copy_key; I32 i = 0; CODE: if (items != 9 diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index 05821e9..73402ac 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -285,7 +285,25 @@ However, only the return value of the C callback currently holds a meaning. =back -Each callback can be specified as a code or a string reference, in which case the function denoted by the string will be used as the callback. +Each callback can be specified as : + +=over 4 + +=item * + +a code reference, which will be called as a subroutine. + +=item * + +a string reference, where the string denotes which subroutine is to be called when magic is triggered. +If the subroutine name is not fully qualified, then the current package at the time the magic is invoked will be used instead. + +=item * + +a reference to C, in which case a no-op magic callback is installed instead of the default one. +This may especially be helpful for 'local' magic, where an empty callback prevents magic from being copied during localization. + +=back Note that C callbacks are I called during global destruction, as there's no way to ensure that the wizard and the C callback weren't destroyed before the variable. diff --git a/t/14-callbacks.t b/t/14-callbacks.t index ce87f51..6a1f56f 100644 --- a/t/14-callbacks.t +++ b/t/14-callbacks.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 22; +use Test::More tests => 26; use Variable::Magic qw; @@ -65,6 +65,21 @@ is($x, $n, 'callback returning undef fails'); is($x, $n, 'short string callback returns the right thing'); } +{ + my $wiz = eval { wizard get => \undef }; + is($@, '', 'wizard with a ref-to-undef callback doesn\'t croak'); + my $b = $n; + my $res = eval { cast $b, $wiz }; + is($@, '', 'cast a wizard with a ref-to-undef callback doesn\'t croak'); + my $x; + eval { + local $SIG{__WARN__} = sub { die }; + $x = $b; + }; + is($@, '', 'ref-to-undef callback doesn\'t warn/croak'); + is($x, $n, 'ref-to-undef callback returns the right thing'); +} + my @callers; $wiz = wizard get => sub { my @c; diff --git a/t/22-len.t b/t/22-len.t index d4f59d1..ab19730 100644 --- a/t/22-len.t +++ b/t/22-len.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 39 + (2 * 2 + 1); +use Test::More tests => 39 + (2 * 2 + 1) + (5 + 2 * 3); use Variable::Magic qw; @@ -167,3 +167,35 @@ SKIP: { dispell @val, $wv; is_deeply \@val, [ 4, 5, 8 ], 'len: after value'; } + +{ + local $@; + + my $wua = eval { wizard len => \undef }; + is $@, '', 'len: noop wizard (for arrays) creation does not croak'; + + my @a = ('a' .. 'z'); + eval { cast @a, $wua }; + is $@, '', 'len: noop wizard (for arrays) cast does not croak'; + + my $l; + eval { $l = $#a }; + is $@, '', 'len: noop wizard (for arrays) invocation does not croak'; + is $l, 25, 'len: noop magic on an array returns the previous length'; + + my $wus = eval { wizard get => \undef, len => \undef }; + is $@, '', 'len: noop wizard (for strings) creation does not croak'; + + for ([ 'euro', 'string' ], [ "\x{20AC}uro", 'unicode string' ]) { + my ($euro, $desc) = @$_; + + eval { cast $euro, $wus }; + is $@, '', 'len: noop wizard (for strings) cast does not croak'; + + eval { pos($euro) = 2 }; + is $@, '', 'len: noop wizard (for strings) invocation does not croak'; + + my ($rest) = ($euro =~ /(.*)/g); + is $rest, 'ro', "len: noop magic on a $desc returns the previous length"; + } +} diff --git a/t/27-local.t b/t/27-local.t index 086d619..ca557e1 100644 --- a/t/27-local.t +++ b/t/27-local.t @@ -5,10 +5,10 @@ use warnings; use Test::More; -use Variable::Magic qw; +use Variable::Magic qw; if (MGf_LOCAL) { - plan tests => 2 * 3 + 1 + 1; + plan tests => 2 * 3 + 1 + (2 + 2 * 7) + 1; } else { plan skip_all => 'No local magic for this perl'; } @@ -24,3 +24,50 @@ my $res = watch { cast $a, $wiz } { }, 'cast'; ok $res, 'local: cast succeeded'; watch { local $a } { local => 1 }, 'localized'; + +{ + local $@; + + my $w1 = eval { wizard local => \undef, data => sub { 'w1' } }; + is $@, '', 'local: noop wizard creation does not croak'; + my $w2 = eval { wizard data => sub { 'w2' } }; + is $@, '', 'local: dummy wizard creation does not croak'; + + { + our $u; + eval { cast $u, $w1 }; + is $@, '', 'local: noop magic (first) cast does not croak'; + is getdata($u, $w1), 'w1', 'local: noop magic (first) cast succeeded'; + eval { cast $u, $w2 }; + is $@, '', 'local: dummy magic (second) cast does not croak'; + is getdata($u, $w2), 'w2', 'local: dummy magic (second) cast succeeded'; + my ($z1, $z2); + eval { + local $u = ''; + $z1 = getdata $u, $w1; + $z2 = getdata $u, $w2; + }; + is $@, '', 'local: noop/dummy magic invocation does not croak'; + is $z1, undef, 'local: noop magic (first) prevented magic copy'; + is $z2, 'w2', 'local: dummy magic (second) was copied'; + } + + { + our $v; + eval { cast $v, $w2 }; + is $@, '', 'local: dummy magic (first) cast does not croak'; + is getdata($v, $w2), 'w2', 'local: dummy magic (first) cast succeeded'; + eval { cast $v, $w1 }; + is $@, '', 'local: noop magic (second) cast does not croak'; + is getdata($v, $w1), 'w1', 'local: noop magic (second) cast succeeded'; + my ($z1, $z2); + eval { + local $v = ''; + $z1 = getdata $v, $w1; + $z2 = getdata $v, $w2; + }; + is $@, '', 'local: dummy/noop magic invocation does not croak'; + is $z2, 'w2', 'local: dummy magic (first) was copied'; + is $z1, undef, 'local: noop magic (second) prevented magic copy'; + } +}