X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=5b4576aed6b1da7f3dfdc55e987aeb52495034a3;hb=fbbe2a83ed1d928afe5a634f01c1b653d7288d9c;hp=44d6c88202bc9e33377153cbdb6260953d0126f2;hpb=20763a0bc2e3d1987ead055b78ef2481aa18514c;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/Magic.xs b/Magic.xs index 44d6c88..5b4576a 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; } @@ -530,7 +550,6 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { U32 ret; dSP; - int count; has_array = SvTYPE(sv) == SVt_PVAV; @@ -550,7 +569,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { } 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; @@ -575,7 +594,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 +604,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,10 +655,16 @@ 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, *umg; SV *key = NULL, *newkey = NULL; + int tied = 0; umg = mg_find(sv, PERL_MAGIC_uvar); /* umg can't be NULL or we wouldn't be there. */ @@ -652,16 +677,24 @@ 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); switch (w->uvar) { case 0: continue; case 2: if (!newkey) - newkey = key = umg->mg_obj = sv_2mortal(newSVsv(umg->mg_obj)); + newkey = key = umg->mg_obj = sv_mortalcopy(umg->mg_obj); } switch (action) { case 0: @@ -681,6 +714,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 */ @@ -919,13 +971,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; @@ -948,6 +1001,7 @@ CODE: MY_CXT_CLONE; MY_CXT = hv; } + #endif /* VMG_THREADSAFE */ SV *_wizard(...)