/* =for apidoc mro_method_changed_in Invalidates method caching on any child classes of the given stash, so that they might notice the changes in this one. Ideally, all instances of C<PL_sub_generation++> in perl source outside of F<mro.c> should be replaced by calls to this. Perl automatically handles most of the common ways a method might be redefined. However, there are a few ways you could change a method in a stash without the cache code noticing, in which case you need to call this method afterwards: 1) Directly manipulating the stash HV entries from XS code. 2) Assigning a reference to a readonly scalar constant into a stash entry in order to create a constant subroutine (like F<constant.pm> does). This same method is available from pure perl via, C<mro::method_changed_in(classname)>. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* mrometa; if(!revstash) continue; mrometa = HvMROMETA(revstash); mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; } } /* The method change may be due to *{$package . "::()"} = \&nil; in overload.pm. */ HvAMAGIC_on(stash); /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; }
/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */ static HV* S_guess_stash(pTHX_ SV* sv) { if (SvOBJECT(sv)) { return SvSTASH(sv); } else { HV *stash = NULL; switch (SvTYPE(sv)) { case SVt_PVCV: if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) return GvSTASH(CvGV(sv)); else if (/* !CvANON(sv) && */ CvSTASH(sv)) return CvSTASH(sv); break; case SVt_PVGV: if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv))) return GvESTASH(MUTABLE_GV(sv)); break; default: break; } return stash; } }
bool Perl_sv_derived_from(pTHX_ SV *sv, const char *name) { char *type; HV *stash; stash = Nullhv; type = Nullch; if (SvGMAGICAL(sv)) mg_get(sv) ; if (SvROK(sv)) { sv = SvRV(sv); type = sv_reftype(sv,0); if (SvOBJECT(sv)) stash = SvSTASH(sv); } else { stash = gv_stashsv(sv, FALSE); } return (type && strEQ(type,name)) || (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes) ? TRUE : FALSE ; }
static void Scalarize(pTHX_ SV *sv, AV *av) { int n = av_len(av)+1; if (n == 0) sv_setpvn(sv,"",0); else { SV **svp; if (n == 1 && (svp = av_fetch(av, 0, 0))) { STRLEN len = 0; char *s = SvPV(*svp,len); #ifdef SvUTF8 int utf8 = SvUTF8(*svp); sv_setpvn(sv,s,len); if (utf8) SvUTF8_on(sv); #else sv_setpvn(sv,s,len); #endif } else { Tcl_DString ds; int i; Tcl_DStringInit(&ds); for (i=0; i < n; i++) { if ((svp = av_fetch(av, i, 0))) { SV *el = *svp; int temp = 0; if (SvROK(el) && !SvOBJECT(SvRV(el)) && SvTYPE(SvRV(el)) == SVt_PVAV) { el = newSVpv("",0); temp = 1; if ((AV *) SvRV(*svp) == av) abort(); Scalarize(aTHX_ el,(AV *) SvRV(*svp)); } Tcl_DStringAppendElement(&ds,Tcl_GetString(el)); if (temp) SvREFCNT_dec(el); } } sv_setpvn(sv,Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); sv_maybe_utf8(sv); Tcl_DStringFree(&ds); } } }
MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv) { if (SvOBJECT(sv) || (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG))) { return INT2PTR(server_rec *, SvObjIV(sv)); } /* next see if we have Apache2->request available */ { request_rec *r = NULL; (void)modperl_tls_get_request_rec(&r); if (r) { return r->server; } } /* modperl_global_get_server_rec is not thread safe w/o locking */ return modperl_global_get_server_rec(); }
static SV * ForceScalar(pTHX_ SV *sv) { if (SvGMAGICAL(sv)) mg_get(sv); if (SvTYPE(sv) == SVt_PVAV) { AV *av = (AV *) sv; SV *newsv = newSVpv("",0); Scalarize(aTHX_ newsv, (AV *) av); av_clear(av); av_store(av,0,newsv); return newsv; } else { if (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* Callbacks and lists often get stringified by mistake due to Tcl/Tk's string fixation - don't change the real value */ SV *newsv = newSVpv("",0); Scalarize(aTHX_ newsv, (AV *) SvRV(sv)); return sv_2mortal(newsv); } else if (!SvOK(sv)) { /* Map undef to null string */ if (SvREADONLY(sv)) { SV *newsv = newSVpv("",0); return sv_2mortal(newsv); } else sv_setpvn(sv,"",0); } return sv; } }
void _mpack_item(SV *res, SV *o) { size_t len, res_len, new_len; char *s, *res_s; res_s = SvPVbyte(res, res_len); unsigned i; if (!SvOK(o)) { new_len = res_len + mp_sizeof_nil(); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_nil(res_s + res_len); return; } if (SvROK(o)) { o = SvRV(o); if (SvOBJECT(o)) { SvGETMAGIC(o); HV *stash = SvSTASH(o); GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0); if (!mtd) croak("Object has no method 'msgpack'"); dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash)); PUTBACK; call_sv((SV *)GvCV(mtd), G_SCALAR); SPAGAIN; SV *pkt = POPs; if (!SvOK(pkt)) croak("O->msgpack returned undef"); s = SvPV(pkt, len); new_len = res_len + len; res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); memcpy(res_s + res_len, s, len); PUTBACK; FREETMPS; LEAVE; return; } switch(SvTYPE(o)) { case SVt_PVAV: { AV *a = (AV *)o; len = av_len(a) + 1; new_len = res_len + mp_sizeof_array(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_array(res_s + res_len, len); for (i = 0; i < len; i++) { SV **item = av_fetch(a, i, 0); if (!item) _mpack_item(res, 0); else _mpack_item(res, *item); } break; } case SVt_PVHV: { HV *h = (HV *)o; len = hv_iterinit(h); new_len = res_len + mp_sizeof_map(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_map(res_s + res_len, len); for (;;) { HE * iter = hv_iternext(h); if (!iter) break; SV *k = hv_iterkeysv(iter); SV *v = HeVAL(iter); _mpack_item(res, k); _mpack_item(res, v); } break; } default: croak("Can't serialize reference"); } return; } switch(SvTYPE(o)) { case SVt_PV: case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: case SVt_REGEXP: if (!looks_like_number(o)) { s = SvPV(o, len); new_len = res_len + mp_sizeof_str(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_str(res_s + res_len, s, len); break; } case SVt_NV: { NV v = SvNV(o); IV iv = (IV)v; if (v != iv) { new_len = res_len + mp_sizeof_double(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_double(res_s + res_len, v); break; } } case SVt_IV: { IV v = SvIV(o); if (v >= 0) { new_len = res_len + mp_sizeof_uint(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_uint(res_s + res_len, v); } else { new_len = res_len + mp_sizeof_int(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_int(res_s + res_len, v); } break; } default: croak("Internal msgpack error %d", SvTYPE(o)); } }
void Perl_mro_isa_changed_in(pTHX_ HV* stash) { HV* isarev; AV* linear_mro; HE* iter; SV** svp; I32 items; bool is_universal; struct mro_meta * meta; HV *isa = NULL; const HEK * const stashhek = HvENAME_HEK(stash); const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; if(!stashname) Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); CLEAR_LINEAR(meta); if (meta->isa) { /* Steal it for our own purposes. */ isa = (HV *)sv_2mortal((SV *)meta->isa); meta->isa = NULL; } /* Inc the package generation, since our @ISA changed */ meta->pkg_gen++; /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ svp = hv_fetchhek(PL_isarev, stashhek, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; is_universal = TRUE; } else { /* Wipe the local method cache otherwise */ meta->cache_gen++; is_universal = FALSE; } /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); /* Changes to @ISA might turn overloading on */ HvAMAGIC_on(stash); /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; /* DESTROY can be cached in SvSTASH. */ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; /* Iterate the isarev (classes that are our children), wiping out their linearization, method and isa caches and upating PL_isarev. */ if(isarev) { HV *isa_hashes = NULL; /* We have to iterate through isarev twice to avoid a chicken and * egg problem: if A inherits from B and both are in isarev, A might * be processed before B and use B's previous linearisation. */ /* First iteration: Wipe everything, but stash away the isa hashes * since we still need them for updating PL_isarev. */ if(hv_iterinit(isarev)) { /* Only create the hash if we need it; i.e., if isarev has any elements. */ isa_hashes = (HV *)sv_2mortal((SV *)newHV()); } while((iter = hv_iternext(isarev))) { HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* revmeta; if(!revstash) continue; revmeta = HvMROMETA(revstash); CLEAR_LINEAR(revmeta); if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; (void) hv_store( isa_hashes, (const char*)&revstash, sizeof(HV *), revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 ); revmeta->isa = NULL; } /* Second pass: Update PL_isarev. We can just use isa_hashes to * avoid another round of stash lookups. */ /* isarev might be deleted from PL_isarev during this loop, so hang * on to it. */ SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev)); if(isa_hashes) { hv_iterinit(isa_hashes); while((iter = hv_iternext(isa_hashes))) { HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter)); HV * const isa = (HV *)HeVAL(iter); const HEK *namehek; /* We're starting at the 2nd element, skipping revstash */ linear_mro = mro_get_linear_isa(revstash); svp = AvARRAY(linear_mro) + 1; items = AvFILLp(linear_mro); namehek = HvENAME_HEK(revstash); if (!namehek) namehek = HvNAME_HEK(revstash); while (items--) { SV* const sv = *svp++; HV* mroisarev; HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); /* That fetch should not fail. But if it had to create a new SV for us, then will need to upgrade it to an HV (which sv_upgrade() can now do for us). */ mroisarev = MUTABLE_HV(HeVAL(he)); SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ (void) hv_storehek(mroisarev, namehek, &PL_sv_yes); } if ((SV *)isa != &PL_sv_undef) { assert(namehek); mro_clean_isarev( isa, HEK_KEY(namehek), HEK_LEN(namehek), HvMROMETA(revstash)->isa, HEK_HASH(namehek), HEK_UTF8(namehek) ); } } } } /* Now iterate our MRO (parents), adding ourselves and everything from our isarev to their isarev. */ /* We're starting at the 2nd element, skipping ourselves here */ linear_mro = mro_get_linear_isa(stash); svp = AvARRAY(linear_mro) + 1; items = AvFILLp(linear_mro); while (items--) { SV* const sv = *svp++; HV* mroisarev; HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); /* That fetch should not fail. But if it had to create a new SV for us, then will need to upgrade it to an HV (which sv_upgrade() can now do for us. */ mroisarev = MUTABLE_HV(HeVAL(he)); SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } /* Delete our name from our former parents' isarevs. */ if(isa && HvARRAY(isa)) mro_clean_isarev(isa, stashname, stashname_len, meta->isa, HEK_HASH(stashhek), HEK_UTF8(stashhek)); }
IV PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); dSP; IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab); SV *result = Nullsv; PUSHSTACKi(PERLSI_MAGIC); SPAGAIN; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(arg); PUTBACK; if (call_pv("Encode::find_encoding", G_SCALAR) != 1) { /* should never happen */ Perl_die(aTHX_ "Encode::find_encoding did not return a value"); return -1; } SPAGAIN; result = POPs; PUTBACK; if (!SvROK(result) || !SvOBJECT(SvRV(result))) { e->enc = Nullsv; if (ckWARN_d(WARN_IO)) Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"", arg); errno = EINVAL; code = -1; } else { /* $enc->renew */ PUSHMARK(sp); XPUSHs(result); PUTBACK; if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { if (ckWARN_d(WARN_IO)) Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method", arg); } else { SPAGAIN; result = POPs; PUTBACK; } e->enc = newSVsv(result); PUSHMARK(sp); XPUSHs(e->enc); PUTBACK; if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { if (ckWARN_d(WARN_IO)) Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines", arg); } else { SPAGAIN; result = POPs; PUTBACK; if (SvTRUE(result)) { e->flags |= NEEDS_LINES; } } PerlIOBase(f)->flags |= PERLIO_F_UTF8; } e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0)); e->inEncodeCall = 0; FREETMPS; LEAVE; POPSTACK; return code; }