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

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

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

SV *PerlIONginxInput_newhandle(pTHX_ ngx_http_request_t *r){    ngx_log_t *log = r->connection->log;    GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Input"));    if (!gv)        return &PL_sv_undef;    (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);    /* Body in memory */    if (r->request_body == NULL || r->request_body->temp_file == NULL) {        ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,                "Open filehandle with 'ngx_input' layer to read from buffers");        PerlIO *f = PerlIO_allocate(aTHX);        if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_input), "<", NULL)) ) {            ngx_log_error(NGX_LOG_ERR, log, 0,                    "Error pushing layer to FH"                    );            return &PL_sv_undef;        }        if (!do_open(gv, "+<&", 3, FALSE, O_RDONLY, 0, f)) {            ngx_log_error(NGX_LOG_ERR, log, 0,                    "Error opening GV"                    );            // FIXME PerlIO_close            return &PL_sv_undef;        }        PerlIONginxInput *st = PerlIOSelf(f, PerlIONginxInput);        st->r = r;    } else {        /* Body in temp file */        ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,                "Open PSGI request body temp file '%s'",                r->request_body->temp_file->file.name.data                );        bool result = do_open(gv,(char*)r->request_body->temp_file->file.name.data, r->request_body->temp_file->file.name.len,FALSE,O_RDONLY,0,NULL);        if (!result) {            ngx_log_error(NGX_LOG_ERR, log, 0,                    "Error opening file"                    );            // FIXME PerlIO_close            return NULL;        }    }    return (SV*)newRV_noinc((SV *)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);	}    }}

MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle){#ifdef MP_TRACE    if (mg_find(TIEHANDLE_SV(handle), PERL_MAGIC_tiedscalar)) {        MP_TRACE_r(MP_FUNC, "untie *%s(0x%lx), REFCNT=%d",                   GvNAME(handle), (unsigned long)handle,                   SvREFCNT(TIEHANDLE_SV(handle)));    }#endif    sv_unmagic(TIEHANDLE_SV(handle), PERL_MAGIC_tiedscalar);}

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

static OP *parser_callback(pTHX_ GV *namegv, SV *psobj, U32 *flagsp) {    dSP;    SV *args_generator;    SV *statement = NULL;    I32 count;     /* call the parser callback     * it should take no arguments and return a coderef which, when called,     * produces the arguments to the keyword function     * the optree we want to generate is for something like     *   mykeyword($code->())     * where $code is the thing returned by the parser function     */     PUSHMARK(SP);    mXPUSHp(GvNAME(namegv), GvNAMELEN(namegv));    PUTBACK;    count = call_sv(psobj, G_ARRAY);    SPAGAIN;    if (count > 1) {        statement = POPs;    }    args_generator = SvREFCNT_inc(POPs);    PUTBACK;     if (!SvROK(args_generator) || SvTYPE(SvRV(args_generator)) != SVt_PVCV) {        croak("The parser function for %s must return a coderef, not %"SVf,              GvNAME(namegv), args_generator);    }     if (SvTRUE(statement)) {        *flagsp |= CALLPARSER_STATEMENT;    }     return newUNOP(OP_ENTERSUB, OPf_STACKED,                   newCVREF(0, newSVOP(OP_CONST, 0, args_generator)));}

MP_INLINE void modperl_io_handle_tie(pTHX_ GV *handle,                                     char *classname, void *ptr){    SV *obj = modperl_ptr2obj(aTHX_ classname, ptr);    modperl_io_handle_untie(aTHX_ handle);    sv_magic(TIEHANDLE_SV(handle), obj, PERL_MAGIC_tiedscalar, (char *)NULL, 0);    SvREFCNT_dec(obj); /* since sv_magic did SvREFCNT_inc */    MP_TRACE_r(MP_FUNC, "tie *%s(0x%lx) => %s, REFCNT=%d",               GvNAME(handle), (unsigned long)handle, classname,               SvREFCNT(TIEHANDLE_SV(handle)));}

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

SV *PerlIONginxError_newhandle(pTHX_ ngx_http_request_t *r){    GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Error"));    if (!gv)        return &PL_sv_undef;    (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);    PerlIO *f = PerlIO_allocate(aTHX);    if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_error), ">", NULL)) ) {         return &PL_sv_undef;    }    if (!do_open(gv, "+>&", 3, FALSE, O_WRONLY, 0, f)) {        return &PL_sv_undef;    }    PerlIONginxError *st = PerlIOSelf(f, PerlIONginxError);    st->log = r->connection->log;    return newRV_noinc((SV*)gv);}

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

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

/*=for apidoc mro_package_movedCall this function to signal to a stash that it has been assigned toanother spot in the stash hierarchy.  C<stash> is the stash that has beenassigned.  C<oldstash> is the stash it replaces, if any.  C<gv> is the globthat is actually being assigned to.This can also be called with a null first argument toindicate that C<oldstash> has been deleted.This function invalidates isa caches on the old stash, on all subpackagesnested inside it, and on the subclasses of all those, includingnon-existent packages that have corresponding entries in C<stash>.It also sets the effective names (C<HvENAME>) on all the stashes asappropriate.If the C<gv> is present and is not in the symbol table, then this functionsimply returns.  This checked will be skipped if C<flags & 1>.=cut*/voidPerl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,                       const GV * const gv, U32 flags){    SV *namesv;    HEK **namep;    I32 name_count;    HV *stashes;    HE* iter;    PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;    assert(stash || oldstash);    /* Determine the name(s) of the location that stash was assigned to     * or from which oldstash was removed.     *     * We cannot reliably use the name in oldstash, because it may have     * been deleted from the location in the symbol table that its name     * suggests, as in this case:     *     *   $globref = /*foo::bar::;     *   Symbol::delete_package("foo");     *   *$globref = /%baz::;     *   *$globref = *frelp::;     *      # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)     *     * So we get it from the gv. But, since the gv may no longer be in the     * symbol table, we check that first. The only reliable way to tell is     * to see whether its stash has an effective name and whether the gv     * resides in that stash under its name. That effective name may be     * different from what gv_fullname4 would use.     * If flags & 1, the caller has asked us to skip the check.     */    if(!(flags & 1)) {        SV **svp;        if(            !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||            !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||            *svp != (SV *)gv        ) return;    }    assert(SvOOK(GvSTASH(gv)));    assert(GvNAMELEN(gv));    assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');    assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');    name_count = HvAUX(GvSTASH(gv))->xhv_name_count;    if (!name_count) {        name_count = 1;        namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;    }    else {        namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;        if (name_count < 0) ++namep, name_count = -name_count - 1;    }    if (name_count == 1) {        if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {            namesv = GvNAMELEN(gv) == 1                     ? newSVpvs_flags(":", SVs_TEMP)                     : newSVpvs_flags("",  SVs_TEMP);        }        else {            namesv = sv_2mortal(newSVhek(*namep));            if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");            else                    sv_catpvs(namesv, "::");        }        if (GvNAMELEN(gv) != 1) {            sv_catpvn_flags(                namesv, GvNAME(gv), GvNAMELEN(gv) - 2,                /* skip trailing :: */                GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES            );        }    }    else {        SV *aname;        namesv = sv_2mortal((SV *)newAV());        while (name_count--) {//.........这里部分代码省略.........

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