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

HV*Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create){    char smallbuf[256];    char *tmpbuf;    HV *stash;    GV *tmpgv;    if (namelen + 3 < sizeof smallbuf)	tmpbuf = smallbuf;    else	New(606, tmpbuf, namelen + 3, char);    Copy(name,tmpbuf,namelen,char);    tmpbuf[namelen++] = ':';    tmpbuf[namelen++] = ':';    tmpbuf[namelen] = '/0';    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);    if (tmpbuf != smallbuf)	Safefree(tmpbuf);    if (!tmpgv)	return 0;    if (!GvHV(tmpgv))	GvHV(tmpgv) = newHV();    stash = GvHV(tmpgv);    if (!HvNAME(stash))	HvNAME(stash) = savepv(name);    return stash;}

/* Converts perl values to equivalent JavaScript values */JSBool PJS_ConvertPerlToJSType(JSContext *cx, JSObject *seen, JSObject *obj, SV *ref, jsval *rval) {    int destroy_seen = 0; /* TODO - do we _need_ to clean up after us? */        if (sv_isobject(ref) && strcmp(HvNAME(SvSTASH(SvRV(ref))), PJS_BOXED_PACKAGE) == 0) {        /* XXX: test this more */        ref = *av_fetch((AV *) SvRV(SvRV(ref)), 0, 0);    }    if (sv_isobject(ref)) { /* blessed */        PJS_Context *pcx;        PJS_Class *pjsc;        JSObject *newobj;        HV *stash = SvSTASH(SvRV(ref));        char *name = HvNAME(stash);        if (strcmp(name, PJS_FUNCTION_PACKAGE) == 0) {            JSFunction *func = INT2PTR(JSFunction *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));            JSObject *obj = JS_GetFunctionObject(func);            *rval = OBJECT_TO_JSVAL(obj);            return JS_TRUE;        }        	if (strcmp(name, PJS_GENERATOR_PACKAGE) == 0) {	  JSObject *obj = INT2PTR(JSObject *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));	  *rval = OBJECT_TO_JSVAL(obj);	  return JS_TRUE;	}

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

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

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

static voidS_attributes__push_fetch(pTHX_ SV *sv){    dSP;    switch (SvTYPE(sv)) {    case SVt_PVCV:    {	cv_flags_t cvflags = CvFLAGS((const CV *)sv);	if (cvflags & CVf_LVALUE) {            XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));        }	if (cvflags & CVf_METHOD) {            XPUSHs(newSVpvs_flags("method", SVs_TEMP));        }	if (cvflags & CVf_PURE) {            XPUSHs(newSVpvs_flags("pure", SVs_TEMP));        }	if (cvflags & CVf_TYPED) {            HV *typestash = CvTYPE((CV*)sv);            XPUSHs(newSVpvn_flags(HvNAME(typestash), HvNAMELEN(typestash),                                  SVs_TEMP|HvNAMEUTF8(typestash)));        }	break;    }    default:	break;    }    PUTBACK;}

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

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

voidPoint::from_SV_check(SV* point_sv){    if (sv_isobject(point_sv) && (SvTYPE(SvRV(point_sv)) == SVt_PVMG)) {        if (!sv_isa(point_sv, perl_class_name(this)) && !sv_isa(point_sv, perl_class_name_ref(this)))            CONFESS("Not a valid %s object (got %s)", perl_class_name(this), HvNAME(SvSTASH(SvRV(point_sv))));        *this = *(Point*)SvIV((SV*)SvRV( point_sv ));    } else {        this->from_SV(point_sv);    }}

SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {    PERL_SET_CONTEXT(my_perl);    {        dSP;        int i;        SV * retval = NULL;        int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;        ENTER;        SAVETMPS;        HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));        GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);        if (gv && isGV(gv)) {            PUSHMARK(SP);            if (len > 1) {                XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]);                for (i = 1; i < len; i++) {                    if (args[i] != NULL) /* skip Nil which gets turned into NULL */                        XPUSHs(sv_2mortal(args[i]));                }            }            else if (len > 0)                if (args != NULL) /* skip Nil which gets turned into NULL */                    XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args);            PUTBACK;            SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));            *count = call_sv(rv, flags);            SPAGAIN;            handle_p5_error(err);            retval = pop_return_values(my_perl, sp, *count, type);            SPAGAIN;        }        else {            ERRSV = newSVpvf("Could not find method /"%s/" of /"%s/" object", name, HvNAME(pkg));        }        PUTBACK;        FREETMPS;        LEAVE;        return retval;    }}

AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) {    dSP;    int i;    AV * const retval = newAV();    int flags = G_ARRAY | G_EVAL;    PERL_SET_CONTEXT(my_perl);    ENTER;    SAVETMPS;    HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));    GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);    if (gv && isGV(gv)) {        I32 count;        PUSHMARK(SP);        for (i = 0; i < len; i++) {            XPUSHs(sv_2mortal(args[i]));        }        PUTBACK;        SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));        count = call_sv(rv, flags);        SPAGAIN;        if (count > 0)            av_extend(retval, count - 1);        for (i = count - 1; i >= 0; i--) {            SV * const next = POPs;            SvREFCNT_inc(next);            if (av_store(retval, i, next) == NULL)                SvREFCNT_dec(next); /* see perlguts Working with AVs */        }    }    else {        ERRSV = newSVpvf("Could not find method /"%s/" of /"%s/" object", name, HvNAME(pkg));    }    PUTBACK;    FREETMPS;    LEAVE;    return retval;}

MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname){    MAGIC *mg;    SV *sv = TIEHANDLE_SV(handle);    if (SvMAGICAL(sv) && (mg = mg_find(sv, PERL_MAGIC_tiedscalar))) {        char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));        if (!strEQ(package, classname)) {            MP_TRACE_r(MP_FUNC, "%s tied to %s", GvNAME(handle), package);            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);    }}

STATIC SV *S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level){    AV* av;    GV* gv;    GV** gvp;    HV* hv = Nullhv;    SV* subgen = Nullsv;    if (!stash)	return &PL_sv_undef;    if (strEQ(HvNAME(stash), name))	return &PL_sv_yes;    if (level > 100)	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",		   HvNAME(stash));    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))	&& (hv = GvHV(gv)))    {	if (SvIV(subgen) == PL_sub_generation) {	    SV* sv;	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {	        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s/n",				  name, HvNAME(stash)) );		return sv;	    }	}	else {	    DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale/n",			      HvNAME(stash)) );	    hv_clear(hv);	    sv_setiv(subgen, PL_sub_generation);	}    }    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {	if (!hv || !subgen) {	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);	    gv = *gvp;	    if (SvTYPE(gv) != SVt_PVGV)		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);	    if (!hv)		hv = GvHVn(gv);	    if (!subgen) {		subgen = newSViv(PL_sub_generation);		GvSV(gv) = subgen;	    }	}	if (hv) {	    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_SYNTAX,		             "Can't locate package %s for @%s::ISA",			    SvPVX(sv), HvNAME(stash));		    continue;		}		if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {		    (void)hv_store(hv,name,len,&PL_sv_yes,0);		    return &PL_sv_yes;		}	    }	    (void)hv_store(hv,name,len,&PL_sv_no,0);	}    }    return boolSV(strEQ(name, "UNIVERSAL"));}

GV *Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type){    register const char *name = nambeg;    register GV *gv = 0;    GV**gvp;    I32 len;    register const char *namend;    HV *stash = 0;    if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */	name++;    for (namend = name; *namend; namend++) {	if ((*namend == ':' && namend[1] == ':')	    || (*namend == '/'' && namend[1]))	{	    if (!stash)		stash = PL_defstash;	    if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */		return Nullgv;	    len = namend - name;	    if (len > 0) {		char smallbuf[256];		char *tmpbuf;		if (len + 3 < sizeof smallbuf)		    tmpbuf = smallbuf;		else		    New(601, tmpbuf, len+3, char);		Copy(name, tmpbuf, len, char);		tmpbuf[len++] = ':';		tmpbuf[len++] = ':';		tmpbuf[len] = '/0';		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);		gv = gvp ? *gvp : Nullgv;		if (gv && gv != (GV*)&PL_sv_undef) {		    if (SvTYPE(gv) != SVt_PVGV)			gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));		    else			GvMULTI_on(gv);		}		if (tmpbuf != smallbuf)		    Safefree(tmpbuf);		if (!gv || gv == (GV*)&PL_sv_undef)		    return Nullgv;		if (!(stash = GvHV(gv)))		    stash = GvHV(gv) = newHV();		if (!HvNAME(stash))		    HvNAME(stash) = savepvn(nambeg, namend - nambeg);	    }	    if (*namend == ':')		namend++;	    namend++;	    name = namend;	    if (!*name)		return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);	}    }

/*=for apidoc mro_get_linear_isaReturns the mro linearisation for the given stash.  By default, thiswill be whatever C<mro_get_linear_isa_dfs> returns unless someother MRO is in effect for the stash.  The return value is aread-only AV*.You are responsible for C<SvREFCNT_inc()> on thereturn value if you plan to store it anywheresemi-permanently (otherwise it might be deletedout from under you the next time the cache isinvalidated).=cut*/AV*Perl_mro_get_linear_isa(pTHX_ HV *stash){    struct mro_meta* meta;    AV *isa;    PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;    if(!SvOOK(stash))        Perl_croak(aTHX_ "Can't linearize anonymous symbol table");    meta = HvMROMETA(stash);    if (!meta->mro_which)        Perl_croak(aTHX_ "panic: invalid MRO!");    isa = meta->mro_which->resolve(aTHX_ stash, 0);    if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */        SV * const namesv =            (HvENAME(stash)||HvNAME(stash))            ? newSVhek(HvENAME_HEK(stash)                       ? HvENAME_HEK(stash)                       : HvNAME_HEK(stash))            : NULL;        if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))        {            AV * const old = isa;            SV **svp;            SV **ovp = AvARRAY(old);            SV * const * const oend = ovp + AvFILLp(old) + 1;            isa = (AV *)sv_2mortal((SV *)newAV());            av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);            *AvARRAY(isa) = namesv;            svp = AvARRAY(isa)+1;            while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);        }        else SvREFCNT_dec(namesv);    }    if (!meta->isa) {        HV *const isa_hash = newHV();        /* Linearisation didn't build it for us, so do it here.  */        SV *const *svp = AvARRAY(isa);        SV *const *const svp_end = svp + AvFILLp(isa) + 1;        const HEK *canon_name = HvENAME_HEK(stash);        if (!canon_name) canon_name = HvNAME_HEK(stash);        while (svp < svp_end) {            (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);        }        (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),                         HEK_LEN(canon_name), HEK_FLAGS(canon_name),                         HV_FETCH_ISSTORE, &PL_sv_undef,                         HEK_HASH(canon_name));        (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);        SvREADONLY_on(isa_hash);        meta->isa = isa_hash;    }    return isa;}

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

//.........这里部分代码省略.........        if (!send_buffer) {	error_sv =	    porbit_system_except ("IDL:omg.org/CORBA/COMM_FAILURE:1.0",				  0, CORBA_COMPLETED_NO);	goto exception;    }    /* Do the marshalling. We accumulate the return types into an array for     * use while demarshalling.     */    return_types = g_ptr_array_new();        if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) {        CORBA_OperationDescription *opr = &desc->operations._buffer[index-PORBIT_OPERATION_BASE];	CORBA_unsigned_long i, st_index;	if (opr->result->kind != CORBA_tk_void)	    g_ptr_array_add (return_types, opr->result);		st_index = 1;	for (i = 0 ; i<opr->parameters._length; i++) {	    SV *arg = (st_index<(CORBA_unsigned_long)items) ? ST(st_index) : &PL_sv_undef;	    switch (opr->parameters._buffer[i].mode) {	    case CORBA_PARAM_IN:		if (!porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, arg)) {		    warn ("Error marshalling parameter '%s'",			  opr->parameters._buffer[i].name);		    error_sv =			porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",					      0, CORBA_COMPLETED_NO);		    goto exception;		}		st_index++;		break;	    case CORBA_PARAM_INOUT:		if (!SvROK(arg) ||		    !porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, SvRV (arg))) {		    		    if (!SvROK (arg))			warn ("INOUT parameter must be a reference");		    else			warn ("Error marshalling parameter '%s'", opr->parameters._buffer[i].name);		    		    error_sv =			porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",					      0, CORBA_COMPLETED_NO);		    goto exception;		}		st_index++;		/* Fall through */	    case CORBA_PARAM_OUT:		g_ptr_array_add (return_types, opr->parameters._buffer[i].type);		break;	    }	}    } else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) {	g_ptr_array_add (return_types, desc->attributes._buffer[index-PORBIT_GETTER_BASE].type);    } else if (index >= PORBIT_SETTER_BASE) {        if (items < 2) {	    warn("%s::%s called without second argument", HvNAME(CvSTASH(cv)), name);	    error_sv =		porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",				      0, CORBA_COMPLETED_NO);	    goto exception;	}	if (!porbit_put_sv (send_buffer, 			    desc->attributes._buffer[index-PORBIT_SETTER_BASE].type, 			    ST(1))) {	    warn ("Error marshalling attribute value");	    error_sv =		porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0",				      0, CORBA_COMPLETED_NO);	    goto exception;	}    }    /* Invoke the operation     */    giop_send_buffer_write(send_buffer); exception:    giop_send_buffer_unuse(send_buffer);    g_free (operation_name_data);    g_free (name);    if (error_sv) {	if (return_types)	    g_ptr_array_free (return_types, TRUE);	porbit_throw (error_sv);    }    return return_types;}

char *p5_stash_name(PerlInterpreter *my_perl, SV *obj) {    HV * const pkg = SvSTASH((SV*)SvRV(obj));    return HvNAME(pkg);}

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

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* THX_MopMcV_get_name(pTHX_ SV* metaclass) {    return newSVpv(HvNAME(SvRV(metaclass)), 0);}