自学教程：C++ CvGV函数代码示例

/* 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;    }}

intmop_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;}

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;}

voidPerl_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 voidS_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 intmodify_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);//.........这里部分代码省略.........

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;//.........这里部分代码省略.........

    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 voidS_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);STATIC voidS_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 __cplusplusextern "C"#endifXS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */XS(boot_ko_6_1_0_perllint_01cc){//.........这里部分代码省略.........

SV* THX_MopMmV_get_name(pTHX_ SV* metamethod) {    return newSVpv(GvNAME(CvGV((CV*) SvRV(metamethod))), 0);}