/* 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; } }
int mop_get_code_info (SV *coderef, char **pkg, char **name) { if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { return 0; } coderef = SvRV(coderef); /* sub is still being compiled */ if (!CvGV(coderef)) { return 0; } /* I think this only gets triggered with a mangled coderef, but if we hit it without the guard, we segfault. The slightly odd return value strikes me as an improvement (mst) */ if ( isGV_with_GP(CvGV(coderef)) ) { GV *gv = CvGV(coderef); *pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) ); *name = GvNAME( CvGV(coderef) ); } else { *pkg = "__UNKNOWN__"; *name = "__ANON__"; } return 1; }
modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv) { char *name = NULL; GV *gv; if (SvROK(sv)) { sv = SvRV(sv); } switch (SvTYPE(sv)) { case SVt_PV: name = SvPVX(sv); return modperl_handler_new(p, apr_pstrdup(p, name)); break; case SVt_PVCV: if (CvANON((CV*)sv)) { return modperl_handler_new_anon(aTHX_ p, (CV*)sv); } if (!(gv = CvGV((CV*)sv))) { Perl_croak(aTHX_ "can't resolve the code reference"); } name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL); return modperl_handler_new(p, name); default: break; }; return NULL; }
bool Stash::can(Raw_string name) const { if (stash) { GV* gv = gv_fetchmeth_autoload(stash, name.value, name.length, -1); return gv && isGV(gv) && CvGV(gv); } return false; }
JSObject* PJS_NewPerlSub( pTHX_ JSContext *cx, JSObject *parent, SV *cvref ) { JSObject *newobj = PJS_CreateJSVis( aTHX_ cx, JS_NewObject(cx, &perlsub_class, NULL, parent), cvref ); if(newobj) { CV *cv = (CV *)SvRV(cvref); const char *fname = CvANON(cv) ? "(anonymous)" : GvENAME(CvGV(cv)); JSString *jstr = JS_InternString(cx, fname); if(!jstr || !JS_DefineProperty(cx, newobj, "name", STRING_TO_JSVAL(jstr), NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT) ) { PJS_unrootJSVis(cx, newobj); newobj = NULL; } } return newobj; }
static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv) { static char *r_keys[] = { "r", "_r", NULL }; HV *hv = (HV *)SvRV(in); SV *sv = (SV *)NULL; int i; for (i=0; r_keys[i]; i++) { int klen = i + 1; /* assumes r_keys[] will never change */ SV **svp; if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) { if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) { /* dig deeper */ return modperl_hv_request_find(aTHX_ sv, classname, cv); } break; } } if (!sv) { Perl_croak(aTHX_ "method `%s' invoked by a `%s' object with no `r' key!", cv ? GvNAME(CvGV(cv)) : "unknown", (SvRV(in) && SvSTASH(SvRV(in))) ? HvNAME(SvSTASH(SvRV(in))) : "unknown"); } return SvROK(sv) ? SvRV(sv) : sv; }
void unroll_this(pTHX_ OP* op) { struct sljit_compiler* compiler = sljit_create_compiler(); HV* seenops = newHV(); #ifdef DEBUG if (getenv("RUNOPS_OPTIMIZED_DEBUG")) { CV *runcv = Perl_find_runcv(NULL); sljit_compiler_verbose(compiler, stderr); DEBUGf(("Unroll %s::%s cv=%p, op=%p (%s)\n", HvNAME_get(CvSTASH(runcv)), GvENAME(CvGV(runcv)), runcv, op, sljit_get_platform_name())); } #endif sljit_emit_enter(compiler, 0, 2, 1, 0); unroll_tree(compiler, seenops, op, NULL); fixup_jumps(compiler, needjumps, labels); // This is needed for things that drop off the runloop without a // return, e.g. S_sortcv. TODO: Make conditional? sljit_emit_return(compiler, SLJIT_MEM, (sljit_w) &PL_op); op->op_ppaddr = sljit_generate_code(compiler); op->op_spare = 3; DEBUGf(("Code at %p\n", op->op_ppaddr)); labels = NULL; needjumps = NULL; SvREFCNT_dec(seenops); sljit_free_compiler(compiler); }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else stash = gv_stashpvn(origname, nsplit - origname, TRUE); } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
const Ref<Code>::Temp Stash::get_method(Raw_string name) const { GV* const glob = gv_fetchmeth_autoload(stash, name.value, name.length, -1); if (glob == NULL || !isGV(glob) || CvGV(glob) == NULL) { throw Runtime_exception("method doesn't exist");//TODO No such method exception?? } CV* const codeval = GvCV(glob); return Code::Value(interp, codeval).take_ref(); }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!CvROOT(cv)) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN(WARN_DEPRECATED) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; #ifdef USE_THREADS sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); #ifdef USE_THREADS sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { register GP *gp; bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; sv_upgrade((SV*)gv, SVt_PVGV); if (SvLEN(gv)) { if (proto) { SvPVX(gv) = NULL; SvLEN(gv) = 0; SvPOK_off(gv); } else Safefree(SvPVX(gv)); } Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); GvLINE(gv) = CopLINE(PL_curcop); GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; /* XXX unsafe for threads if eval_owner isn't held */ start_subparse(0,0); /* Create CV in compcv. */ GvCV(gv) = PL_compcv; LEAVE; PL_sub_generation++; CvGV(GvCV(gv)) = gv; CvFILE(GvCV(gv)) = CopFILE(PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; #ifdef USE_THREADS CvOWNER(GvCV(gv)) = 0; if (!CvMUTEXP(GvCV(gv))) { New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(GvCV(gv))); } #endif /* USE_THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); } } }
STATIC const char * _sub_name( pTHX ) { const CV *const cv = _curcv( aTHX ); if ( cv ) { const GV *const gv = CvGV( cv ); if ( gv ) { return GvENAME( gv ); } } return NULL; }
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv) { SV *sv = (SV *)NULL; MAGIC *mg; if (SvROK(in)) { SV *rv = (SV*)SvRV(in); switch (SvTYPE(rv)) { case SVt_PVMG: sv = rv; break; case SVt_PVHV: sv = modperl_hv_request_find(aTHX_ in, classname, cv); break; default: Perl_croak(aTHX_ "panic: unsupported request_rec type %d", (int)SvTYPE(rv)); } } /* might be Apache2::ServerRec::warn method */ if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) { request_rec *r = NULL; (void)modperl_tls_get_request_rec(&r); if (!r) { Perl_croak(aTHX_ "Apache2->%s called without setting Apache2->request!", cv ? GvNAME(CvGV(cv)) : "unknown"); } return r; } /* there could be pool magic attached to custom $r object, so make * sure that mg->mg_ptr is set */ if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) { return (request_rec *)mg->mg_ptr; } else { if (classname && !sv_derived_from(in, classname)) { /* XXX: find something faster than sv_derived_from */ return NULL; } return INT2PTR(request_rec *, SvIV(sv)); } return NULL; }
SV* THX_MopMcV_get_method(pTHX_ SV* metaclass, SV* name) { HV* stash = (HV*) SvRV(metaclass); HE* method_gv_he = hv_fetch_ent(stash, name, 0, 0); if (method_gv_he != NULL) { GV* method_gv = (GV*) HeVAL(method_gv_he); CV* method = GvCV(method_gv); if (method != NULL && GvSTASH(CvGV(method)) == stash) { return newRV_inc((SV*) method); } } return NULL; }
bool THX_MopMcV_has_method(pTHX_ SV* metaclass, SV* name) { HV* stash = (HV*) SvRV(metaclass); HE* method_gv_he = hv_fetch_ent(stash, name, 0, 0); if (method_gv_he != NULL) { GV* method_gv = (GV*) HeVAL(method_gv_he); CV* method = GvCV(method_gv); if (method != NULL && GvSTASH(CvGV(method)) == stash) { return TRUE; } } return FALSE; }
STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } }
SV* THX_newMopMmV(pTHX_ SV* code, U32 flags) { SV* method; CV* cv = (CV*) newSV(0); sv_upgrade((SV*) cv, SVt_PVCV); CvISXSUB_on(cv); CvXSUB(cv) = _MopMmV_wrapper; CvXSUBANY(cv).any_uv = PTR2UV(code); CvFILE(cv) = __FILE__; CvANON_off(cv); CvMETHOD_on(cv); SvREFCNT_inc(code); method = newMopOV(newRV_inc((SV*) cv)); if (flags & MopMmVf_STEAL_STASH) { MopMmV_assign_to_stash(method, CvGV(SvRV(code)), CvSTASH(SvRV(code))); } return method; }
/* helper for the default modify handler for builtin attributes */ static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { SV *attr; int nret; for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { STRLEN len; const char *name = SvPV_const(attr, len); const bool negated = (*name == '-'); HV *typestash; if (negated) { name++; len--; } switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { case 4: if (memEQ(name, "pure", 4)) { if (negated) Perl_croak(aTHX_ "Illegal :-pure attribute"); CvPURE_on(sv); goto next_attr; } break; case 5: if (memEQ(name, "const", 5)) { if (negated) CvCONST_off(sv); else { #ifndef USE_CPERL const bool warn = (!CvANON(sv) || CvCLONED(sv)) && !CvCONST(sv); CvCONST_on(sv); if (warn) break; #else CvCONST_on(sv); #endif } goto next_attr; } break; case 6: switch (name[3]) { case 'l': if (memEQ(name, "lvalue", 6)) { bool warn = !CvISXSUB(MUTABLE_CV(sv)) && CvROOT(MUTABLE_CV(sv)) && !CvLVALUE(MUTABLE_CV(sv)) != negated; if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; if (warn) break; goto next_attr; } break; case 'h': if (memEQ(name, "method", 6)) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; goto next_attr; } break; } break; default: if (len > 10 && memEQ(name, "prototype(", 10)) { SV * proto = newSVpvn(name+10,len-11); HEK *const hek = CvNAME_HEK((CV *)sv); SV *subname; if (name[len-1] != ')') Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list"); if (hek) subname = sv_2mortal(newSVhek(hek)); else subname=(SV *)CvGV((const CV *)sv); if (ckWARN(WARN_ILLEGALPROTO)) Perl_validate_proto(aTHX_ subname, proto, TRUE); Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, (const GV *)subname, name+10, len-11, SvUTF8(attr)); sv_setpvn(MUTABLE_SV(sv), name+10, len-11); if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv)); goto next_attr; } break; } if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) { CvTYPED_on(sv); CvTYPE_set((CV*)sv, typestash); continue; } break; case SVt_IV: case SVt_PVIV: case SVt_PVMG: if (memEQ(name, "unsigned", 8) && (SvIOK(sv) || SvUOK(sv))) { if (negated) /* :-unsigned alias for :signed */ SvIsUV_off(sv); else SvIsUV_on(sv); continue; } /* fallthru - all other data types */ default: if (memEQ(name, "const", 5) && !(SvFLAGS(sv) & SVf_PROTECT)) { if (negated) SvREADONLY_off(sv); else SvREADONLY_on(sv); continue; } if (memEQs(name, len, "shared")) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); continue; } break; } /* anything recognized had a 'continue' above */ *retlist++ = attr; nret++; next_attr: ; } return nret; }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; char *packname = ""; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { packname = SvPV_nolen((SV*)stash); stash = Nullhv; } else { packname = HvNAME(stash); } } if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); if (CvXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; SvPVX(cv) = (char *)name; /* cast to lose constness warning */ SvCUR(cv) = len; return gv; } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); sv_setpv(varsv, packname); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; HV* ostash = stash; if (stash && SvTYPE(stash) < SVt_PVHV) stash = Nullhv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, FALSE); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, FALSE)) stash = gv_stashpvn(origname, nsplit - origname, TRUE); } ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
SV * DeadCode(pTHX) { #ifdef PURIFY return Nullsv; #else SV* sva; SV* sv; SV* ret = newRV_noinc((SV*)newAV()); register SV* svend; int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) == SVt_PVCV) { CV *cv = (CV*)sv; AV* padlist = CvPADLIST(cv), *argav; SV** svp; SV** pad; int i = 0, j, levelm, totm = 0, levelref, totref = 0; int levels, tots = 0, levela, tota = 0, levelas, totas = 0; int dumpit = 0; if (CvXSUB(sv)) { continue; /* XSUB */ } if (!CvGV(sv)) { continue; /* file-level scope. */ } if (!CvROOT(cv)) { /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ continue; /* autoloading stub. */ } do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); if (CvDEPTH(cv)) { PerlIO_printf(Perl_debug_log, " busy\n"); continue; } svp = AvARRAY(padlist); while (++i <= AvFILL(padlist)) { /* Depth. */ SV **args; pad = AvARRAY((AV*)svp[i]); argav = (AV*)pad[0]; if (!argav || (SV*)argav == &PL_sv_undef) { PerlIO_printf(Perl_debug_log, " closure-template\n"); continue; } args = AvARRAY(argav); levelm = levels = levelref = levelas = 0; levela = sizeof(SV*) * (AvMAX(argav) + 1); if (AvREAL(argav)) { for (j = 0; j < AvFILL(argav); j++) { if (SvROK(args[j])) { PerlIO_printf(Perl_debug_log, " ref in args!\n"); levelref++; } /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { levelas += SvLEN(args[j])/SvREFCNT(args[j]); } } } for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ if (SvROK(pad[j])) { levelref++; do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); dumpit = 1; } /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ else if (SvTYPE(pad[j]) >= SVt_PVAV) { if (!SvPADMY(pad[j])) { levelref++; do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); dumpit = 1; } } else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { levels++; levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); /* Dump(pad[j],4); */ } } PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", i, levelref, levelm, levels, levela, levelas); totm += levelm; tota += levela; totas += levelas; tots += levels; totref += levelref; if (dumpit) do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); } if (AvFILL(padlist) > 1) { PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", totref, totm, tots, tota, totas); } tref += totref; tm += totm; ts += tots; ta += tota; tas += totas; } } } PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); return ret; #endif /* !PURIFY */ }
void c_test (int max){ int i; for (f=1) } #line 23 "ko_6_1_0_perllint_01cc.c" #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #ifdef PERL_IMPLICIT_CONTEXT #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) #else #define croak_xs_usage S_croak_xs_usage #endif #endif /* NOTE: the prototype of newXSproto() is different in versions of perls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ #line 75 "ko_6_1_0_perllint_01cc.c" XS(XS_main_c_test); /* prototype to pass -Wmissing-prototypes */ XS(XS_main_c_test) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif if (items != 1) croak_xs_usage(cv, "max"); PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { int max = (int)SvIV(ST(0)); #line 22 "ko_6_1_0_perllint_01cc.xs" I32* temp; #line 93 "ko_6_1_0_perllint_01cc.c" #line 24 "ko_6_1_0_perllint_01cc.xs" temp = PL_markstack_ptr++; c_test(max); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; /* assume stack size is correct */ #line 104 "ko_6_1_0_perllint_01cc.c" PUTBACK; return; } } #ifdef __cplusplus extern "C" #endif XS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */ XS(boot_ko_6_1_0_perllint_01cc) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif #if (PERL_REVISION == 5 && PERL_VERSION < 9) char* file = __FILE__; #else const char* file = __FILE__; #endif PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XS_VERSION_BOOTCHECK ; newXS("main::c_test", XS_main_c_test, file); #if (PERL_REVISION == 5 && PERL_VERSION >= 9) if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); #endif XSRETURN_YES; }
SV* THX_MopMmV_get_name(pTHX_ SV* metamethod) { return newSVpv(GvNAME(CvGV((CV*) SvRV(metamethod))), 0); }