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;
}
JSObject*
PJS_InitPerlSubClass(
pTHX_
JSContext *cx,
JSObject *global
) {
CV *pcv = get_cv(NAMESPACE"PerlSub::prototype", 0);
JSObject *proto;
if(pcv && (CvROOT(pcv) || CvXSUB(pcv))) {
proto = JS_InitClass(
cx,
global,
PJS_GetPackageObject(aTHX_ cx, PerlSubPkg),
&perlsub_class,
PerlSub, 1,
NULL, NULL,
NULL, NULL
);
return PJS_CreateJSVis(aTHX_ cx, proto,
sv_2mortal(newRV_inc((SV *)pcv)));
}
croak("Can't locate PerlSub::prototype");
return NULL;
}
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 */
}
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;
}
/* 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;
}
