X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=65858173557c76dd7977609b65b4dc462af8df5c;hb=e8fc00c8574346d926269a64ac51d5da2ad2019e;hp=c0c4297b82177cb431e9d548c2da6b3d91736b0a;hpb=7c1660201c0aafbfb8842d97f6728b74005b286b;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/Magic.xs b/Magic.xs index c0c4297..6585817 100644 --- a/Magic.xs +++ b/Magic.xs @@ -89,6 +89,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { # define Newx(v, n, c) New(0, v, n, c) #endif +#ifndef NewOp +# define NewOp(m, var, c, type) Newz(m, var, c, type) +#endif + #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif @@ -101,6 +105,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { # define PERL_MAGIC_ext '~' #endif +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + #ifndef MGf_COPY # define MGf_COPY 0 #endif @@ -317,6 +325,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { MAGIC *mg = NULL, *moremagic = NULL; MGWIZ *w; SV *data; + U32 oldgmg = SvGMAGICAL(sv); w = SV2MGWIZ(wiz); @@ -344,10 +353,21 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { mg->mg_flags |= MGf_LOCAL; #endif /* MGf_LOCAL */ + if (SvTYPE(sv) < SVt_PVHV) + goto done; + + /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get + * magic is actually never called for them. If the GMAGICAL flag was off before + * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's + * now on, then this wizard has get magic. Hence we can work around the + * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic + * has uvar callbacks, it will be turned back on later. */ + if (!oldgmg && SvGMAGICAL(sv)) + SvGMAGICAL_off(sv); + #if VMG_UVAR - if (w->uvar && SvTYPE(sv) >= SVt_PVHV) { + if (w->uvar) { MAGIC *prevmagic; - int add_uvar = 1; struct ufuncs uf[2]; uf[0].uf_val = vmg_svt_val; @@ -366,8 +386,8 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { if (mg) { /* Found another uvar magic. */ struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr; if (olduf->uf_val == vmg_svt_val) { - /* It's our uvar magic, nothing to do. */ - add_uvar = 0; + /* It's our uvar magic, nothing to do. oldgmg was true. */ + goto done; } else { /* It's another uvar magic, backup it and replace it by ours. */ uf[1] = *olduf; @@ -375,13 +395,13 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { } } - if (add_uvar) { - vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf)); - } - + vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf)); + /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be + * handled by our uvar callback. */ } #endif /* VMG_UVAR */ +done: return 1; } @@ -526,13 +546,10 @@ STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SV *svr; - I32 len, has_array; - U32 ret; + U32 len, ret; + svtype t = SvTYPE(sv); dSP; - int count; - - has_array = SvTYPE(sv) == SVt_PVAV; ENTER; SAVETMPS; @@ -541,16 +558,24 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { EXTEND(SP, 3); PUSHs(sv_2mortal(newRV_inc(sv))); PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); - if (has_array) { + if (t < SVt_PVAV) { + STRLEN l; + U8 *s = (U8 *) SvPV_const(sv, l); + if (DO_UTF8(sv)) + len = utf8_length(s, s + l); + else + len = l; + mPUSHu(len); + } else if (t == SVt_PVAV) { len = av_len((AV *) sv) + 1; - mPUSHi(len); + mPUSHu(len); } else { len = 0; PUSHs(&PL_sv_undef); } PUTBACK; - count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR); + call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR); SPAGAIN; svr = POPs; @@ -560,7 +585,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { FREETMPS; LEAVE; - return has_array ? ret - 1 : ret; + return t == SVt_PVAV ? ret - 1 : ret; } STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { @@ -575,7 +600,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { if (SvTYPE(wiz) == SVTYPEMASK) return 0; - /* So that it can survive tmp cleanup in vmg_cb_call */ + /* So that it survives the temp cleanup in vmg_cb_call */ SvREFCNT_inc(sv); #if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686) @@ -585,14 +610,14 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { SvMAGIC_set(sv, mg); #endif - /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and - * mg->mg_ptr reference count */ ret = vmg_cb_call1e(SV2MGWIZ(wiz)->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 */ --SvREFCNT(sv); + /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and + * mg->mg_ptr reference count */ return ret; } @@ -636,15 +661,21 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { #endif /* MGf_LOCAL */ #if VMG_UVAR +STATIC OP *vmg_pp_resetuvar(pTHX) { + SvRMAGICAL_on(cSVOP_sv); + return NORMAL; +} + STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { struct ufuncs *uf; - MAGIC *mg; - SV *key = NULL; + MAGIC *mg, *umg; + SV *key = NULL, *newkey = NULL; + int tied = 0; - mg = mg_find(sv, PERL_MAGIC_uvar); - /* mg can't be NULL or we wouldn't be there. */ - key = mg->mg_obj; - uf = (struct ufuncs *) mg->mg_ptr; + umg = mg_find(sv, PERL_MAGIC_uvar); + /* umg can't be NULL or we wouldn't be there. */ + key = umg->mg_obj; + uf = (struct ufuncs *) umg->mg_ptr; if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); } if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); } @@ -652,11 +683,25 @@ 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; - if ((mg->mg_type != PERL_MAGIC_ext) - || (mg->mg_private < SIG_MIN) - || (mg->mg_private > SIG_MAX)) { continue; } + switch (mg->mg_type) { + case PERL_MAGIC_ext: + break; + case PERL_MAGIC_tied: + ++tied; + continue; + default: + continue; + } + if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX) + continue; w = SV2MGWIZ(mg->mg_ptr); - if (!w->uvar) { continue; } + switch (w->uvar) { + case 0: + continue; + case 2: + if (!newkey) + newkey = key = umg->mg_obj = sv_mortalcopy(umg->mg_obj); + } switch (action) { case 0: if (w->cb_fetch) { vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); } @@ -675,6 +720,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { } } + if (SvRMAGICAL(sv) && !tied) { + /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly + * mistaken for a tied hash by the rest of hv_common. It will be reset by + * the op_ppaddr of a new fake op injected between the current and the next + * one. */ + OP *o = PL_op; + if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) { + SVOP *svop; + NewOp(1101, svop, 1, SVOP); + svop->op_type = OP_STUB; + svop->op_ppaddr = vmg_pp_resetuvar; + svop->op_next = o->op_next; + svop->op_flags = 0; + svop->op_sv = sv; + o->op_next = (OP *) svop; + } + SvRMAGICAL_off(sv); + } + return 0; } #endif /* VMG_UVAR */ @@ -913,13 +977,14 @@ BOOT: newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE)); } +#if VMG_THREADSAFE + void CLONE(...) PROTOTYPE: DISABLE PREINIT: HV *hv; CODE: -#if VMG_THREADSAFE { HE *key; dMY_CXT; @@ -942,6 +1007,7 @@ CODE: MY_CXT_CLONE; MY_CXT = hv; } + #endif /* VMG_THREADSAFE */ SV *_wizard(...) @@ -970,7 +1036,7 @@ CODE: + 1 #endif /* MGf_LOCAL */ #if VMG_UVAR - + 4 + + 5 #endif /* VMG_UVAR */ ) { croak(vmg_wrongargnum); } @@ -1013,16 +1079,17 @@ CODE: VMG_SET_CB(ST(i++), store); VMG_SET_CB(ST(i++), exists); VMG_SET_CB(ST(i++), delete); + cb = ST(i++); + if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete) + w->uvar = SvTRUE(cb) ? 2 : 1; + else + w->uvar = 0; #endif /* VMG_UVAR */ #if VMG_MULTIPLICITY w->owner = aTHX; #endif /* VMG_MULTIPLICITY */ - - w->vtbl = t; - w->sig = sig; -#if VMG_UVAR - w->uvar = (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete); -#endif /* VMG_UVAR */ + w->vtbl = t; + w->sig = sig; sv = MGWIZ2SV(w); mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);