From: Vincent Pit Date: Sun, 8 Feb 2009 14:36:32 +0000 (+0100) Subject: Get current op information in magic callbacks X-Git-Tag: v0.30~12 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=b4a1e34ba2c3dc4623d5a399d3c56a84fc14439d Get current op information in magic callbacks --- diff --git a/Magic.xs b/Magic.xs index e474114..aeea182 100644 --- a/Magic.xs +++ b/Magic.xs @@ -229,8 +229,11 @@ STATIC U16 vmg_gensig(pTHX) { typedef struct { MGVTBL *vtbl; + U16 sig; - U16 uvar; + U8 uvar; + U8 opinfo; + SV *cb_data; SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free; #if MGf_COPY @@ -486,21 +489,77 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { return 1; } +/* ... OP info ............................................................. */ + +#define VMG_OP_INFO_NAME 1 +#define VMG_OP_INFO_OBJECT 2 + +STATIC STRLEN *vmg_op_name_len = NULL; + +STATIC HV *vmg_b__op_stash = NULL; + +STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) { +#define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W)) + switch (opinfo) { + case VMG_OP_INFO_NAME: + if (!vmg_op_name_len) { + OPCODE t; + Newx(vmg_op_name_len, MAXO, STRLEN); + for (t = 0; t < OP_max; ++t) + vmg_op_name_len[t] = strlen(PL_op_name[t]); + } + break; + case VMG_OP_INFO_OBJECT: + if (!vmg_b__op_stash) { + require_pv("B.pm"); + vmg_b__op_stash = gv_stashpv("B::OP", 1); + } + break; + default: + break; + } +} + +STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) { +#define vmg_op_info(W) vmg_op_info(aTHX_ (W)) + if (!PL_op) + return &PL_sv_undef; + + switch (opinfo) { + case VMG_OP_INFO_NAME: { + OPCODE t = PL_op->op_type; + return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t])); + } + case VMG_OP_INFO_OBJECT: + return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))), + vmg_b__op_stash); + default: + break; + } + + return &PL_sv_undef; +} + /* ... svt callbacks ....................................................... */ -#define VMG_CB_CALL_ARGS_MASK 15 -#define VMG_CB_CALL_EVAL 16 +#define VMG_CB_CALL_ARGS_MASK 15 +#define VMG_CB_CALL_ARGS_SHIFT 4 +#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) +#define VMG_CB_CALL_EVAL 4 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){ va_list ap; SV *svr; int ret; - unsigned int i; - unsigned int args = flags & VMG_CB_CALL_ARGS_MASK; - unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0; + unsigned int i, args, opinfo, eval; dSP; + args = flags & VMG_CB_CALL_ARGS_MASK; + flags >>= VMG_CB_CALL_ARGS_SHIFT; + opinfo = flags & VMG_CB_CALL_OPINFO; + eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0; + ENTER; SAVETMPS; @@ -514,6 +573,8 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){ PUSHs(sva ? sva : &PL_sv_undef); } va_end(ap); + if (opinfo) + XPUSHs(vmg_op_info(opinfo)); PUTBACK; call_sv(cb, G_SCALAR | eval); @@ -531,21 +592,29 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){ return ret; } -#define vmg_cb_call1(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), 0) -#define vmg_cb_call1e(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL) -#define vmg_cb_call2(I, S, D, S2) vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2)) -#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3)) +#define vmg_cb_call1(I, S, D) \ + vmg_cb_call(aTHX_ (I), (S), (D), (flags << VMG_CB_CALL_ARGS_SHIFT)) +#define vmg_cb_call2(I, S, D, S2) \ + vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 1), (S2)) +#define vmg_cb_call3(I, S, D, S2, S3) \ + vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 2), (S2), (S3)) STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj); + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int flags = w->opinfo; + return vmg_cb_call1(w->cb_get, sv, mg->mg_obj); } STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj); + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int flags = w->opinfo; + return vmg_cb_call1(w->cb_set, sv, mg->mg_obj); } STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SV *svr; + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int opinfo = w->opinfo; U32 len, ret; svtype t = SvTYPE(sv); @@ -573,9 +642,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { len = 0; PUSHs(&PL_sv_undef); } + if (opinfo) + XPUSHs(vmg_op_info(opinfo)); PUTBACK; - call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR); + call_sv(w->cb_len, G_SCALAR); SPAGAIN; svr = POPs; @@ -589,17 +660,24 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { } STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj); + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int flags = w->opinfo; + return vmg_cb_call1(w->cb_clear, sv, mg->mg_obj); } STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { SV *wiz = (SV *) mg->mg_ptr; + const MGWIZ *w; + unsigned int flags; int ret = 0; /* This may happen in global destruction */ if (SvTYPE(wiz) == SVTYPEMASK) return 0; + w = SV2MGWIZ(mg->mg_ptr); + flags = w->opinfo | VMG_CB_CALL_EVAL; + /* So that it survives the temp cleanup in vmg_cb_call */ SvREFCNT_inc(sv); @@ -610,7 +688,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { SvMAGIC_set(sv, mg); #endif - ret = vmg_cb_call1e(SV2MGWIZ(wiz)->cb_free, sv, mg->mg_obj); + ret = vmg_cb_call1(w->cb_free, sv, mg->mg_obj); /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */ @@ -630,6 +708,8 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, # endif ) { SV *keysv; + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int flags = w->opinfo; int ret; if (keylen == HEf_SVKEY) { @@ -638,7 +718,7 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, keysv = newSVpvn(key, keylen); } - ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv); + ret = vmg_cb_call3(w->cb_copy, sv, mg->mg_obj, keysv, nsv); if (keylen != HEf_SVKEY) { SvREFCNT_dec(keysv); @@ -656,7 +736,9 @@ STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { #if MGf_LOCAL STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { - return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj); + const MGWIZ *w = SV2MGWIZ(mg->mg_ptr); + unsigned int flags = w->opinfo; + return vmg_cb_call1(w->cb_local, nsv, mg->mg_obj); } #endif /* MGf_LOCAL */ @@ -682,7 +764,8 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - MGWIZ *w; + const MGWIZ *w; + unsigned int flags; switch (mg->mg_type) { case PERL_MAGIC_ext: break; @@ -695,6 +778,7 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX) continue; w = SV2MGWIZ(mg->mg_ptr); + flags = w->opinfo; switch (w->uvar) { case 0: continue; @@ -935,10 +1019,11 @@ STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) { VMG_CLONE_CB(exists); VMG_CLONE_CB(delete); #endif /* VMG_UVAR */ - z->owner = aTHX; - z->vtbl = t; - z->sig = w->sig; - z->uvar = w->uvar; + z->owner = aTHX; + z->vtbl = t; + z->sig = w->sig; + z->uvar = w->uvar; + z->opinfo = w->opinfo; return z; } @@ -975,6 +1060,8 @@ BOOT: newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN)); newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL)); newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE)); + newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME)); + newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT)); } #if VMG_THREADSAFE @@ -1025,7 +1112,7 @@ PREINIT: CODE: dMY_CXT; - if (items != 7 + if (items != 8 #if MGf_COPY + 1 #endif /* MGf_COPY */ @@ -1057,6 +1144,10 @@ CODE: Newx(w, 1, MGWIZ); VMG_SET_CB(ST(i++), data); + cb = ST(i++); + w->opinfo = SvOK(cb) ? SvUV(cb) : 0; + if (w->opinfo) + vmg_op_info_init(w->opinfo); VMG_SET_SVT_CB(ST(i++), get); VMG_SET_SVT_CB(ST(i++), set); VMG_SET_SVT_CB(ST(i++), len); @@ -1169,3 +1260,13 @@ CODE: RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig)); OUTPUT: RETVAL + +void +_cleanup() +PROTOTYPE: +PPCODE: + if (vmg_op_name_len) { + Safefree(vmg_op_name_len); + vmg_op_name_len = NULL; + } + XSRETURN(0); diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index 79ca7e9..b82e214 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -267,6 +267,14 @@ The perl patchlevel this module was built with, or C<0> for non-debugging perls. True iff this module could have been built with thread-safety features enabled. +=head2 C + +Value to pass with C to get the current op name in the magic callbacks. + +=head2 C + +Value to pass with C to get a C object representing the current op in the magic callbacks. + =head1 FUNCTIONS =cut @@ -291,7 +299,8 @@ BEGIN { store => sub { my ($ref, $data, $key) = @_; ... }, exists => sub { my ($ref, $data, $key) = @_; ... }, delete => sub { my ($ref, $data, $key) = @_; ... }, - copy_key => $bool + copy_key => $bool, + op_info => [ 0 | 1 | 2 ] This function creates a 'wizard', an opaque type that holds the magic information. It takes a list of keys / values as argument, whose keys can be : @@ -321,6 +330,10 @@ C, C, C, C, C, C, C, C, C Code references to the corresponding magic callbacks. You don't have to specify all of them : the magic associated with undefined entries simply won't be hooked. In those callbacks, C<$_[0]> is always a reference to the magic object and C<$_[1]> is always the private data (or C when no private data constructor was supplied). + +Moreover, when you pass C<< op_info => $num >> to C, the last element of C<@_> will be the current op name if C<$num == VMG_OP_INFO_NAME> and a C object representing the current op if C<$num == VMG_OP_INFO_OBJECT>. +Both have a performance hit, but just getting the name is lighter than getting the op object. + Other arguments are specific to the magic hooked : =over 8 @@ -366,7 +379,7 @@ However, only the return value of the C callback currently holds a meaning. sub wizard { croak 'Wrong number of arguments for wizard()' if @_ % 2; my %opts = @_; - my @keys = qw/sig data get set len clear free/; + my @keys = qw/sig data op_info get set len clear free/; push @keys, 'copy' if MGf_COPY; push @keys, 'dup' if MGf_DUP; push @keys, 'local' if MGf_LOCAL; @@ -446,15 +459,19 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( 'funcs' => [ qw/wizard gensig getsig cast getdata dispell/ ], - 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/, - qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR/, - qw/VMG_COMPAT_SCALAR_LENGTH_NOLEN/, + 'consts' => [ + qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/, + qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN/, qw/VMG_PERL_PATCHLEVEL/, - qw/VMG_THREADSAFE/ ] + qw/VMG_THREADSAFE/, + qw/VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/ + ] ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; +END { _cleanup() } + =head1 CAVEATS If you store a magic object in the private data slot, the magic won't be accessible by L since it's not copied by assignation. diff --git a/t/01-import.t b/t/01-import.t index 1b9f066..f02df0e 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,11 +3,18 @@ use strict; use warnings; -use Test::More tests => 19; +use Test::More tests => 21; require Variable::Magic; -for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_PERL_PATCHLEVEL VMG_THREADSAFE/) { +for (qw/wizard gensig getsig cast getdata dispell + SIG_MIN SIG_MAX SIG_NBR + MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR + VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID + VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN + VMG_PERL_PATCHLEVEL + VMG_THREADSAFE + VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/) { eval { Variable::Magic->import($_) }; is($@, '', 'import ' . $_); } diff --git a/t/10-simple.t b/t/10-simple.t index 1fdefcd..adfea12 100644 --- a/t/10-simple.t +++ b/t/10-simple.t @@ -7,7 +7,7 @@ use Test::More tests => 46; use Variable::Magic qw/wizard gensig getsig cast dispell MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/; -my $args = 7; +my $args = 8; ++$args if MGf_COPY; ++$args if MGf_DUP; ++$args if MGf_LOCAL; diff --git a/t/14-callbacks.t b/t/14-callbacks.t index e14d570..eae92fd 100644 --- a/t/14-callbacks.t +++ b/t/14-callbacks.t @@ -3,9 +3,9 @@ use strict; use warnings; -use Test::More tests => 12; +use Test::More tests => 12 + (2 * 5 + 2 * 6 + 2 * 5); -use Variable::Magic qw/wizard cast/; +use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/; my $wiz = eval { wizard get => sub { undef } }; is($@, '', 'wizard creation doesn\'t croak'); @@ -64,3 +64,40 @@ is($@, '', 'caller into callback doesn\'t croak'); is_deeply(\@callers, [ ([ 'main', $0, __LINE__-3 ]) x 2, ], 'caller into callback into eval returns the right thing'); + +for ([ 'get', '$c', 'sassign' ], [ 'len', '@c', 'padav' ]) { + my ($key, $var, $exp) = @$_; + + for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT, 3) { + my ($c, @c); + + # We must test for the $op correctness inside the callback because, if we + # bring it out, it will go outside of the eval STRING scope, and what it + # points to will no longer exist. + eval { + $wiz = wizard $key => sub { + my $op = $_[-1]; + my $desc = "$key magic with op_info == $op_info"; + if ($op_info == 1) { + is $op, $exp, "$desc gets the right op info"; + } elsif ($op_info == 2) { + isa_ok $op, 'B::OP', $desc; + is $op->name, $exp, "$desc gets the right op info"; + } else { + is $op, undef, "$desc gets the right op info"; + } + () + }, op_info => $op_info + }; + is $@, '', "$key wizard with op_info == $op_info doesn't croak"; + + eval "cast $var, \$wiz"; + is $@, '', "$key cast with op_info == $op_info doesn't croak"; + + eval "my \$x = $var"; + is $@, '', "$key magic with op_info == $op_info doesn't croak"; + + eval "dispell $var, \$wiz"; + is $@, '', "$key dispell with op_info == $op_info doesn't croak"; + } +}