#include "EXTERN.h"
#include "perl.h"
-EXT char rcsid[];
-
GV *
gv_AVadd(register GV *gv)
{
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
- gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
+ gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv))
- gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
+ gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
sv_setpv(GvSV(gv), name);
{
dTHR;
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))
- Safefree(SvPVX(gv));
+ 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) = curcop->cop_line;
- GvFILEGV(gv) = curcop->cop_filegv;
+ GvLINE(gv) = PL_curcop->cop_line;
+ GvFILEGV(gv) = PL_curcop->cop_filegv;
+ GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, '*', name, len);
- GvSTASH(gv) = stash;
+ GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi)
GvMULTI_on(gv);
+ if (doproto) { /* Replicate part of newSUB here. */
+ SvIOK_off(gv);
+ ENTER;
+ start_subparse(0,0); /* Create CV in compcv. */
+ GvCV(gv) = PL_compcv;
+ LEAVE;
+
+ PL_sub_generation++;
+ CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+ CvFILEGV(GvCV(gv)) = PL_curcop->cop_filegv;
+ 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 void
+STATIC void
gv_init_sv(GV *gv, I32 sv_type)
{
switch (sv_type) {
if (!stash)
return 0;
if ((level > 100) || (level < -100))
- croak("Recursive inheritance detected");
+ croak("Recursive inheritance detected while looking for method '%s' in package '%s'",
+ name, HvNAME(stash));
DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
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) >= sub_generation)
+ 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*)&sv_undef) ? GvAV(gv) : Nullav;
+ av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
packlen -= 7;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
- if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
dTHR; /* just for SvREFCNT_dec */
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
if (av) {
SV** svp = AvARRAY(av);
- I32 items = AvFILL(av) + 1;
+ /* 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 (dowarn)
- warn("Can't locate package %s for @%s::ISA",
+ dTHR; /* just for ckWARN */
+ if (ckWARN(WARN_MISC))
+ warner(WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
if (cv = GvCV(topgv))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
- GvCVGEN(topgv) = sub_generation;
+ 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;
+ }
}
}
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
- HvNAME(curcop->cop_stash)));
+ HvNAME(PL_curcop->cop_stash)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( deb("Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import"))
- gv = (GV*)&sv_yes;
+ gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(stash, name, nend - name, TRUE);
}
GV*
gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
{
+ dTHR;
static char autoload[] = "AUTOLOAD";
static STRLEN autolen = 8;
GV* gv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
- if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
- warn(
+ if (ckWARN(WARN_DEPRECATED) && !method &&
+ (GvCVGEN(gv) || GvSTASH(gv) != stash))
+ warner(WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
register char *namend;
HV *stash = 0;
U32 add_gvflags = 0;
- char *tmpbuf;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
name++;
(*namend == ':' && namend[1] == ':'))
{
if (!stash)
- stash = defstash;
+ stash = PL_defstash;
if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
if (len > 0) {
- New(601, tmpbuf, len+3, char);
+ 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);
- Safefree(tmpbuf);
- if (!gvp || *gvp == (GV*)&sv_undef)
- return Nullgv;
- gv = *gvp;
-
- if (SvTYPE(gv) == SVt_PVGV)
- GvMULTI_on(gv);
- else if (!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;
- else
- gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
if (!(stash = GvHV(gv)))
stash = GvHV(gv) = newHV();
namend++;
name = namend;
if (!*name)
- return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
+ return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
}
}
len = namend - name;
/* No stash in name, so see how we can default */
if (!stash) {
- if (isIDFIRST(*name)) {
+ if (isIDFIRST(*name)
+ || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name)))
+ {
bool global = FALSE;
if (isUPPER(*name)) {
- if (*name > 'I') {
- if (*name == 'S' && (
- strEQ(name, "SIG") ||
- strEQ(name, "STDIN") ||
- strEQ(name, "STDOUT") ||
- strEQ(name, "STDERR") ))
- global = TRUE;
- }
- else if (*name > 'E') {
- if (*name == 'I' && strEQ(name, "INC"))
- global = TRUE;
- }
- else if (*name > 'A') {
- if (*name == 'E' && strEQ(name, "ENV"))
- global = TRUE;
- }
+ if (*name == 'S' && (
+ strEQ(name, "SIG") ||
+ strEQ(name, "STDIN") ||
+ strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR")))
+ global = TRUE;
+ else if (*name == 'I' && strEQ(name, "INC"))
+ global = TRUE;
+ else if (*name == 'E' && strEQ(name, "ENV"))
+ global = TRUE;
else if (*name == 'A' && (
strEQ(name, "ARGV") ||
- strEQ(name, "ARGVOUT") ))
+ strEQ(name, "ARGVOUT")))
global = TRUE;
}
else if (*name == '_' && !name[1])
global = TRUE;
if (global)
- stash = defstash;
- else if ((COP*)curcop == &compiling) {
- stash = curstash;
- if (add && (hints & HINT_STRICT_VARS) &&
+ stash = PL_defstash;
+ else if ((COP*)PL_curcop == &PL_compiling) {
+ stash = PL_curstash;
+ if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
sv_type != SVt_PVGV &&
sv_type != SVt_PVFM &&
{
gvp = (GV**)hv_fetch(stash,name,len,0);
if (!gvp ||
- *gvp == (GV*)&sv_undef ||
+ *gvp == (GV*)&PL_sv_undef ||
SvTYPE(*gvp) != SVt_PVGV)
{
stash = 0;
}
}
else
- stash = curcop->cop_stash;
+ stash = PL_curcop->cop_stash;
}
else
- stash = defstash;
+ stash = PL_defstash;
}
/* By this point we should have a stash and a name */
if (!stash) {
- if (add) {
- warn("Global symbol \"%s\" requires explicit package name", name);
- ++error_count;
- stash = curstash ? curstash : defstash; /* avoid core dumps */
- add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
- : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
- : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
- : 0);
- }
- else
+ if (!add)
return Nullgv;
+ {
+ char sv_type_char = ((sv_type == SVt_PV) ? '$'
+ : (sv_type == SVt_PVAV) ? '@'
+ : (sv_type == SVt_PVHV) ? '%'
+ : 0);
+ if (sv_type_char)
+ warn("Global symbol \"%c%s\" requires explicit package name",
+ sv_type_char, name);
+ else
+ warn("Global symbol \"%s\" requires explicit package name",
+ name);
+ }
+ ++PL_error_count;
+ stash = PL_curstash ? PL_curstash : PL_defstash; /* avoid core dumps */
+ add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
+ : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
+ : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
+ : 0);
}
if (!SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
gvp = (GV**)hv_fetch(stash,name,len,add);
- if (!gvp || *gvp == (GV*)&sv_undef)
+ if (!gvp || *gvp == (GV*)&PL_sv_undef)
return Nullgv;
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV) {
gv_init_sv(gv, sv_type);
}
return gv;
+ } else if (add & GV_NOINIT) {
+ return gv;
}
/* Adding a new symbol */
- if (add & 4)
+ if (add & GV_ADDWARN)
warn("Had to create %s unexpectedly", nambeg);
- gv_init(gv, stash, name, len, add & 2);
+ gv_init(gv, stash, name, len, add & GV_ADDMULTI);
gv_init_sv(gv, sv_type);
GvFLAGS(gv) |= add_gvflags;
AV* av = GvAVn(gv);
GvMULTI_on(gv);
sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
- if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
+ /* NOTE: No support for tied ISA */
+ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+ && AvFILLp(av) == -1)
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
if (strEQ(name, "SIG")) {
HV *hv;
I32 i;
- siggv = gv;
- GvMULTI_on(siggv);
- hv = GvHVn(siggv);
- hv_magic(hv, siggv, 'S');
- for(i=1;sig_name[i];i++) {
+ PL_siggv = gv;
+ GvMULTI_on(PL_siggv);
+ hv = GvHVn(PL_siggv);
+ hv_magic(hv, PL_siggv, 'S');
+ for(i=1;PL_sig_name[i];i++) {
SV ** init;
- init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
+ init=hv_fetch(hv,PL_sig_name[i],strlen(PL_sig_name[i]),1);
if(init)
- sv_setsv(*init,&sv_undef);
- psig_ptr[i] = 0;
- psig_name[i] = 0;
+ sv_setsv(*init,&PL_sv_undef);
+ PL_psig_ptr[i] = 0;
+ PL_psig_name[i] = 0;
}
- /* initialize signal stack */
- signalstack = newAV();
- AvREAL_off(signalstack);
- av_extend(signalstack, 30);
- av_fill(signalstack, 0);
}
break;
case '&':
if (len > 1)
break;
- ampergv = gv;
- sawampersand = TRUE;
+ PL_ampergv = gv;
+ PL_sawampersand = TRUE;
goto ro_magicalize;
case '`':
if (len > 1)
break;
- leftgv = gv;
- sawampersand = TRUE;
+ PL_leftgv = gv;
+ PL_sawampersand = TRUE;
goto ro_magicalize;
case '\'':
if (len > 1)
break;
- rightgv = gv;
- sawampersand = TRUE;
+ PL_rightgv = gv;
+ PL_sawampersand = TRUE;
goto ro_magicalize;
case ':':
if (len > 1)
break;
- sv_setpv(GvSV(gv),chopset);
+ sv_setpv(GvSV(gv),PL_chopset);
goto magicalize;
case '?':
if (len > 1)
break;
#ifdef COMPLEX_STATUS
- sv_upgrade(GvSV(gv), SVt_PVLV);
+ (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
#endif
goto magicalize;
+ case '!':
+ if (len > 1)
+ break;
+ if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
+ HV* stash = gv_stashpvn("Errno",5,FALSE);
+ if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+ dSP;
+ PUTBACK;
+ perl_require_pv("Errno.pm");
+ SPAGAIN;
+ stash = gv_stashpvn("Errno",5,FALSE);
+ if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+ croak("Can't use %%! because Errno.pm is not available");
+ }
+ }
+ goto magicalize;
+ case '-':
+ if (len > 1)
+ break;
+ else {
+ AV* av = GvAVn(gv);
+ sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
+ }
+ goto magicalize;
case '#':
case '*':
- if (dowarn && len == 1 && sv_type == SVt_PV)
- warn("Use of $%s is deprecated", name);
+ if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
+ warner(WARN_DEPRECATED, "Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
- case '!':
case '^':
case '~':
case '=':
- case '-':
case '%':
case '.':
case '(':
case '/':
case '|':
case '\001':
+ case '\002':
+ case '\003':
case '\004':
case '\005':
case '\006':
case '\010':
+ case '\011': /* NOT \t in EBCDIC */
case '\017':
- case '\t':
case '\020':
case '\024':
case '\027':
if (len > 1)
break;
goto magicalize;
+ case '\023':
+ if (len > 1)
+ break;
+ goto ro_magicalize;
case '+':
+ if (len > 1)
+ break;
+ else {
+ AV* av = GvAVn(gv);
+ sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
+ }
+ /* FALL THROUGH */
case '1':
case '2':
case '3':
case '7':
case '8':
case '9':
- case '\023':
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
if (len > 1)
break;
sv_setpv(GvSV(gv),"\f");
- formfeed = GvSV(gv);
+ PL_formfeed = GvSV(gv);
break;
case ';':
if (len > 1)
case ']':
if (len == 1) {
SV *sv = GvSV(gv);
- sv_upgrade(sv, SVt_PVNV);
- sv_setpv(sv, patchlevel);
+ (void)SvUPGRADE(sv, SVt_PVNV);
+ sv_setpv(sv, PL_patchlevel);
(void)sv_2nv(sv);
SvREADONLY_on(sv);
}
SvREFCNT(io) = 1;
SvOBJECT_on(io);
iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
- if (!iogv)
+ /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
+ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
{
- if (hv != defstash)
+ if (hv != PL_defstash)
gv_check(hv); /* nested package */
}
else if (isALPHA(*HeKEY(entry))) {
gv = (GV*)HeVAL(entry);
- if (GvMULTI(gv))
+ if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
continue;
- curcop->cop_line = GvLINE(gv);
+ PL_curcop->cop_line = GvLINE(gv);
filegv = GvFILEGV(gv);
- curcop->cop_filegv = filegv;
+ PL_curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
- warn("Name \"%s::%s\" used only once: possible typo",
+ warner(WARN_ONCE,
+ "Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
GV *
newGVgen(char *pack)
{
- return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+ return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)PL_gensym++),
TRUE, SVt_PVGV);
}
}
else {
/* Adding a new name to a subroutine invalidates method cache */
- sub_generation++;
+ PL_sub_generation++;
}
}
return gp;
}
if (gp->gp_cv) {
/* Deleting the name of a subroutine invalidates method cache */
- sub_generation++;
+ PL_sub_generation++;
}
if (--gp->gp_refcnt > 0) {
if (gp->gp_egv == gv)
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- if (mg && amtp->was_ok_am == amagic_generation
- && amtp->was_ok_sub == sub_generation)
+ if (mg && amtp->was_ok_am == PL_amagic_generation
+ && amtp->was_ok_sub == PL_sub_generation)
return AMT_AMAGIC(amtp);
if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
int i;
DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
- amt.was_ok_am = amagic_generation;
- amt.was_ok_sub = sub_generation;
+ amt.was_ok_am = PL_amagic_generation;
+ amt.was_ok_sub = PL_sub_generation;
amt.fallback = AMGfallNO;
amt.flags = 0;
#ifdef OVERLOAD_VIA_HASH
gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
- if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
+ if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
int filled=0;
int i;
char *cp;
SV* sv;
SV** svp;
- /* Work with "fallback" key, which we assume to be first in AMG_names */
+ /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
- if (( cp = (char *)AMG_names[0] ) &&
+ if (( cp = (char *)PL_AMG_names[0] ) &&
(svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
if (SvTRUE(sv)) amt.fallback=AMGfallYES;
else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
}
for (i = 1; i < NofAMmeth; i++) {
cv = 0;
- cp = (char *)AMG_names[i];
+ cp = (char *)PL_AMG_names[i];
svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
- if (svp && ((sv = *svp) != &sv_undef)) {
+ if (svp && ((sv = *svp) != &PL_sv_undef)) {
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
if (!SvOK(sv)) break;
- gv = gv_fetchmethod(stash, SvPV(sv, na));
+ gv = gv_fetchmethod(stash, SvPV(sv, PL_na));
if (gv) cv = GvCV(gv);
break;
}
SV* sv = NULL;
SV** svp;
- /* Work with "fallback" key, which we assume to be first in AMG_names */
+ /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
- if ( cp = AMG_names[0] ) {
+ if ( cp = PL_AMG_names[0] ) {
/* Try to find via inheritance. */
gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
if (gv) sv = GvSV(gv);
}
for (i = 1; i < NofAMmeth; i++) {
- SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
+ SV *cookie = sv_2mortal(newSVpvf("(%s", cp = PL_AMG_names[i]));
DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
cp, HvNAME(stash)) );
/* don't fill the cache while looking up! */
GV *ngv;
DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
- SvPV(GvSV(gv), na), cp, HvNAME(stash)) );
+ SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) );
if (!SvPOK(GvSV(gv))
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
FALSE)))
return FALSE;
}
-/* During call to this subroutine stack can be reallocated. It is
- * advised to call SPAGAIN macro in your code after call */
-
SV*
amagic_call(SV *left, SV *right, int method, int flags)
{
CV **cvp=NULL, **ocvp=NULL;
AMT *amtp, *oamtp;
int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
- int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
+ int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
int logic;
/* look for substituted methods */
+ /* In all the covered cases we should be called with assign==0. */
switch (method) {
case inc_amg:
- if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
- || ((cv = cvp[off=add_amg]) && (postpr=1))) {
- right = &sv_yes; lr = -1; assign = 1;
+ force_cpy = 1;
+ if ((cv = cvp[off=add_ass_amg])
+ || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
+ right = &PL_sv_yes; lr = -1; assign = 1;
}
break;
case dec_amg:
- if (((cv = cvp[off=subtr_ass_amg]) && (inc_dec_ass=1))
- || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
- right = &sv_yes; lr = -1; assign = 1;
+ force_cpy = 1;
+ if ((cv = cvp[off = subtr_ass_amg])
+ || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
+ right = &PL_sv_yes; lr = -1; assign = 1;
}
break;
case bool__amg:
break;
case copy_amg:
{
- SV* ref=SvRV(left);
- if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+ /*
+ * SV* ref causes confusion with the interpreter variable of
+ * the same name
+ */
+ SV* tmpRef=SvRV(left);
+ if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
/*
* Just to be extra cautious. Maybe in some
* additional cases sv_setsv is safe, too.
*/
- SV* newref = newSVsv(ref);
+ SV* newref = newSVsv(tmpRef);
SvOBJECT_on(newref);
- SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
+ SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
return newref;
}
}
lr = 1;
}
break;
+ case iter_amg: /* XXXX Eventually should do to_gv. */
+ case to_sv_amg:
+ case to_av_amg:
+ case to_hv_amg:
+ case to_gv_amg:
+ case to_cv_amg:
+ /* FAIL safe */
+ return NULL; /* Delegate operation to standard mechanisms. */
+ break;
default:
goto not_found;
}
if (off==-1) off=method;
msg = sv_2mortal(newSVpvf(
"Operation `%s': no method found,%sargument %s%s%s%s",
- AMG_names[method + assignshift],
+ PL_AMG_names[method + assignshift],
(flags & AMGf_unary ? " " : "\n\tleft "),
SvAMAGIC(left)?
"in overloaded package ":
}
return NULL;
}
+ force_cpy = force_cpy || assign;
}
}
if (!notfound) {
DEBUG_o( deb(
"Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
- AMG_names[off],
+ PL_AMG_names[off],
method+assignshift==off? "" :
" (initially `",
method+assignshift==off? "" :
- AMG_names[method+assignshift],
+ PL_AMG_names[method+assignshift],
method+assignshift==off? "" : "')",
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
flags & AMGf_unary? " for argument" : "",
HvNAME(stash),
fl? ",\n\tassignment variant used": "") );
+ }
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
*/
- if ((method + assignshift==off
- && (assign || method==inc_amg || method==dec_amg))
- || inc_dec_ass) RvDEEPCP(left);
- }
+ /* We need to copy in following cases:
+ * a) Assignment form was called.
+ * assignshift==1, assign==T, method + 1 == off
+ * b) Increment or decrement, called directly.
+ * assignshift==0, assign==0, method + 0 == off
+ * c) Increment or decrement, translated to assignment add/subtr.
+ * assignshift==0, assign==T,
+ * force_cpy == T
+ * d) Increment or decrement, translated to nomethod.
+ * assignshift==0, assign==0,
+ * force_cpy == T
+ * e) Assignment form translated to nomethod.
+ * assignshift==1, assign==T, method + 1 != off
+ * force_cpy == T
+ */
+ /* off is method, method+assignshift, or a result of opcode substitution.
+ * In the latter case assignshift==0, so only notfound case is important.
+ */
+ if (( (method + assignshift == off)
+ && (assign || (method == inc_amg) || (method == dec_amg)))
+ || force_cpy)
+ RvDEEPCP(left);
{
- dTHR;
dSP;
BINOP myop;
SV* res;
myop.op_next = Nullop;
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ PUSHSTACKi(PERLSI_OVERLOAD);
ENTER;
SAVEOP();
- op = (OP *) &myop;
- if (PERLDB_SUB && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
+ PL_op = (OP *) &myop;
+ if (PERLDB_SUB && PL_curstash != PL_debstash)
+ PL_op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark(ARGS);
- EXTEND(sp, notfound + 5);
+ EXTEND(SP, notfound + 5);
PUSHs(lr>0? right: left);
PUSHs(lr>0? left: right);
- PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
+ PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
+ PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
}
PUSHs((SV*)cv);
PUTBACK;
- if (op = pp_entersub(ARGS))
- runops();
+ if (PL_op = pp_entersub(ARGS))
+ CALLRUNOPS();
LEAVE;
SPAGAIN;
res=POPs;
PUTBACK;
+ POPSTACK;
CATCH_SET(oldcatch);
if (postpr) {
}
}
#endif /* OVERLOAD */
+
https://perl5.git.perl.org / perl5.git / blobdiff