GV *
Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
GV *gv = gv_fetchmeth(stash, name, len, level);
if (!gv) {
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
CV *cv;
GV **gvp;
if (!stash)
return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
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) || CvXSUB(cv)))
return Nullgv;
/* Have an autoload */
if (level < 0) /* Cannot do without a stub */
gv_fetchmeth(stash, name, len, 0);
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
return Nullgv;
return *gvp;
}
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;
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;
}
CV *
PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, char *method, CV ** save)
{
GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0);
#if 0
Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME(s->stash), method, gv);
#endif
if (gv) {
return *save = GvCV(gv);
}
else {
return *save = (CV *) - 1;
}
}
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
AV* av;
GV* topgv;
GV* gv;
GV** gvp;
CV* cv;
if (!stash)
return 0;
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
topgv = Nullgv;
else {
topgv = *gvp;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
if ((cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
return topgv;
/* Stale cached entry: junk it */
SvREFCNT_dec(cv);
GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
else if (GvCVGEN(topgv) == PL_sub_generation)
return 0; /* cache indicates sub doesn't exist */
}
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
char* packname = HvNAME(stash);
STRLEN packlen = strlen(packname);
if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
GvAV(gv) = (AV*)SvREFCNT_inc(av);
}
}
}
if (av) {
SV** svp = AvARRAY(av);
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
(level >= 0) ? level + 1 : level - 1);
if (gv)
goto gotcha;
}
}
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
HV* lastchance;
if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
if ((gv = gv_fetchmeth(lastchance, name, len,
(level >= 0) ? level + 1 : level - 1)))
{
gotcha:
/*
* Cache method in topgv if:
* 1. topgv has no synonyms (else inheritance crosses wires)
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv &&
GvREFCNT(topgv) == 1 &&
(cv = GvCV(gv)) &&
(CvROOT(cv) || CvXSUB(cv)))
{
if ((cv = GvCV(topgv)))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
GvCVGEN(topgv) = PL_sub_generation;
}
return gv;
}
else if (topgv && GvREFCNT(topgv) == 1) {
/* cache the fact that the method is not defined */
GvCVGEN(topgv) = PL_sub_generation;
}
}
}
return 0;
}
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;
}
