static void pe_var_stop(pe_watcher *_ev) { MAGIC **mgp; MAGIC *mg; pe_var *ev = (pe_var*) _ev; SV *sv = SvRV(ev->variable); if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) { warn("Var unmagic'd already?"); return; } mgp = &SvMAGIC(sv); while ((mg = *mgp)) { if (mg->mg_type == 'U' && mg->mg_obj == (SV*)ev) break; mgp = &mg->mg_moremagic; } if(!mg) { warn("Couldn't find var magic"); return; } *mgp = mg->mg_moremagic; EvFree(8, mg->mg_ptr); EvFree(11, mg); }
static bool sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) return TRUE; } return FALSE; }
static struct wsgi_request *coroae_current_wsgi_req(void) { MAGIC *mg; SV *current = CORO_CURRENT; for (mg = SvMAGIC (current); mg; mg = mg->mg_moremagic) { if (mg->mg_type == PERL_MAGIC_ext + 1 && mg->mg_virtual == &uwsgi_coroae_vtbl) { return (struct wsgi_request *) mg->mg_ptr; } } uwsgi_log("[BUG] current_wsgi_req NOT FOUND !!!\n"); // TODO allow to survive api call error as in the python plugin exit(1); }
void blizkost_get_bound_pmc(PerlInterpreter *my_perl, blizkost_nexus **nexusr, SV *sv, PMC **targetr) { MAGIC *mgp; if (SvMAGICAL(sv)) for (mgp = SvMAGIC(sv); mgp; mgp = mgp->mg_moremagic) if (mgp->mg_virtual == &blizkost_binder_vtbl) goto gotmagic; croak("blizkost: expected a bound PMC, got something else"); gotmagic: *nexusr = (blizkost_nexus *)(mgp->mg_ptr); *targetr = (PMC *)mgp->mg_obj; }
static char *pe_var_start(pe_watcher *_ev, int repeat) { STRLEN n_a; struct ufuncs *ufp; MAGIC **mgp; MAGIC *mg; pe_var *ev = (pe_var*) _ev; SV *sv = ev->variable; if (!_ev->callback) return "without callback"; if (!sv || !SvOK(sv)) return "watching what?"; if (!ev->events) return "without poll events specified"; sv = SvRV(sv); if (SvREADONLY(sv)) return "cannot trace read-only variable"; (void)SvUPGRADE(sv, SVt_PVMG); mgp = &SvMAGIC(sv); while ((mg = *mgp)) { mgp = &mg->mg_moremagic; } EvNew(11, mg, 1, MAGIC); Zero(mg, 1, MAGIC); mg->mg_type = 'U'; mg->mg_virtual = &PL_vtbl_uvar; *mgp = mg; EvNew(8, ufp, 1, struct ufuncs); ufp->uf_val = ev->events & PE_R? tracevar_r : 0; ufp->uf_set = ev->events & PE_W? tracevar_w : 0; ufp->uf_index = PTR2IV(ev); mg->mg_ptr = (char *) ufp; mg->mg_obj = (SV*) ev; mg_magical(sv); if (!SvMAGICAL(sv)) return "mg_magical didn't"; return 0; }
GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { AV* av; GV* topgv; GV* gv; GV** gvp; CV* cv; if (!stash) return 0; if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) topgv = Nullgv; else { topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); if ((cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) return topgv; /* Stale cached entry: junk it */ SvREFCNT_dec(cv); GvCV(topgv) = cv = Nullcv; GvCVGEN(topgv) = 0; } else if (GvCVGEN(topgv) == PL_sub_generation) return 0; /* cache indicates sub doesn't exist */ } gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; /* create and re-create @.*::SUPER::ISA on demand */ if (!av || !SvMAGIC(av)) { char* packname = HvNAME(stash); STRLEN packlen = strlen(packname); if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; basestash = gv_stashpvn(packname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); GvAV(gv) = (AV*)SvREFCNT_inc(av); } } } if (av) { SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } gv = gv_fetchmeth(basestash, name, len, (level >= 0) ? level + 1 : level - 1); if (gv) goto gotcha; } } /* if at top level, try UNIVERSAL */ if (level == 0 || level == -1) { HV* lastchance; if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { if ((gv = gv_fetchmeth(lastchance, name, len, (level >= 0) ? level + 1 : level - 1))) { gotcha: /* * Cache method in topgv if: * 1. topgv has no synonyms (else inheritance crosses wires) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ if (topgv && GvREFCNT(topgv) == 1 && (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { if ((cv = GvCV(topgv))) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); GvCVGEN(topgv) = PL_sub_generation; } return gv; } else if (topgv && GvREFCNT(topgv) == 1) { /* cache the fact that the method is not defined */ GvCVGEN(topgv) = PL_sub_generation; } } } return 0; }
static void modperl_filter_mg_set(pTHX_ SV *obj, modperl_filter_t *filter) { sv_magic(SvRV(obj), (SV *)NULL, PERL_MAGIC_ext, NULL, -1); SvMAGIC(SvRV(obj))->mg_ptr = (char *)filter; }