#include "EXTERN.h"
#include "perl.h"
-extern char rcsid[];
+EXT char rcsid[];
GV *
gv_AVadd(gv)
char *name;
{
char tmpbuf[1200];
+ STRLEN tmplen;
GV *gv;
- sprintf(tmpbuf,"::_<%s", name);
- gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
+ sprintf(tmpbuf, "_<%s", name);
+ tmplen = strlen(tmpbuf);
+ gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
+ if (!isGV(gv))
+ gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
- if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
+ if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
GvMULTI_on(gv);
if (perldb)
hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv))
Safefree(SvPVX(gv));
- Newz(602,gp, 1, GP);
+ Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
- GvREFCNT(gv) = 1;
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = curcop->cop_line;
GvFILEGV(gv) = curcop->cop_filegv;
if (!stash)
return 0;
- if (level > 100)
+ if ((level > 100) || (level < -100))
croak("Recursive inheritance detected");
- gvp = (GV**)hv_fetch(stash, name, len, TRUE);
-
DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
- topgv = *gvp;
- if (SvTYPE(topgv) != SVt_PVGV)
- gv_init(topgv, stash, name, len, TRUE);
-
- if (cv=GvCV(topgv)) {
- if (GvCVGEN(topgv) >= sub_generation)
- return topgv; /* valid cached inheritance */
- if (!GvCVGEN(topgv)) { /* not an inheritance cache */
- return topgv;
- }
- else {
- /* stale cached entry, just junk it */
- GvCV(topgv) = cv = 0;
+
+ 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) >= sub_generation)
+ return topgv;
+ /* Stale cached entry: junk it */
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
}
- /* if cv is still set, we have to free it if we find something to cache */
gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
SvPVX(sv), HvNAME(stash));
continue;
}
- gv = gv_fetchmeth(basestash, name, len, level + 1);
- if (gv) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
- }
- GvCV(topgv) = GvCV(gv); /* cache the CV */
- GvCVGEN(topgv) = sub_generation; /* valid for now */
- return gv;
- }
+ gv = gv_fetchmeth(basestash, name, len,
+ (level >= 0) ? level + 1 : level - 1);
+ if (gv)
+ goto gotcha;
}
}
- if (!level) {
+ if (level == 0 || level == -1) {
if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
- if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
+ if (gv = gv_fetchmeth(lastchance, name, len,
+ (level >= 0) ? level + 1 : level - 1)) {
+ gotcha:
+ /* Use topgv for cache only if it has no synonyms */
+ if (topgv && GvREFCNT(topgv) == 1) {
+ if (cv = GvCV(topgv))
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
+ GvCVGEN(topgv) = sub_generation;
}
- GvCV(topgv) = GvCV(gv); /* cache the CV */
- GvCVGEN(topgv) = sub_generation; /* valid for now */
return gv;
}
}
}
if (!gv) {
- CV* cv;
-
if (strEQ(name,"import"))
gv = (GV*)&sv_yes;
- else if (strNE(name, "AUTOLOAD")) {
- gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
- if (gv && (cv = GvCV(gv))) { /* One more chance... */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
- sv_catpvn(tmpstr,"::", 2);
- sv_catpvn(tmpstr, name, nend - name);
- sv_setsv(GvSV(CvGV(cv)), tmpstr);
- SvTAINTED_off(GvSV(CvGV(cv)));
- }
- }
+ else
+ gv = gv_autoload(stash, name, nend - name);
}
+
+ return gv;
+}
+
+GV*
+gv_autoload(stash, name, len)
+HV* stash;
+char* name;
+STRLEN len;
+{
+ static char autoload[] = "AUTOLOAD";
+ static STRLEN autolen = 8;
+ 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, 0)))
+ return Nullgv;
+ cv = GvCV(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);
+ if (!isGV(vargv))
+ gv_init(vargv, varstash, autoload, autolen, FALSE);
+ varsv = GvSV(vargv);
+ sv_setpv(varsv, HvNAME(stash));
+ sv_catpvn(varsv, "::", 2);
+ sv_catpvn(varsv, name, len);
+ SvTAINTED_off(varsv);
return gv;
}
#ifdef VMS
warn("Weird package name \"%s\" truncated", name);
#else
- warn("Weird package name \"%.*s...\" truncated", namelen, name);
+ warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
#endif
}
Copy(name,tmpbuf,namelen,char);
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
name);
- if (GvCV(*gvp))
+ if (GvCVu(*gvp))
warn("(Did you mean &%s instead?)\n", name);
stash = 0;
}
sv_setpv(GvSV(gv),chopset);
goto magicalize;
+ case '?':
+ if (len > 1)
+ break;
+#ifdef COMPLEX_STATUS
+ sv_upgrade(GvSV(gv), SVt_PVLV);
+#endif
+ goto magicalize;
+
case '#':
case '*':
if (dowarn && len == 1 && sv_type == SVt_PV)
/* FALL THROUGH */
case '[':
case '!':
- case '?':
case '^':
case '~':
case '=':
break;
case ']':
if (len == 1) {
- SV *sv;
- sv = GvSV(gv);
+ SV *sv = GvSV(gv);
sv_upgrade(sv, SVt_PVNV);
sv_setpv(sv, patchlevel);
+ (void)sv_2nv(sv);
+ SvREADONLY_on(sv);
}
break;
}
GP* gp;
{
gp->gp_refcnt++;
+ if (gp->gp_cv) {
+ if (gp->gp_cvgen) {
+ /* multi-named GPs cannot be used for method cache */
+ SvREFCNT_dec(gp->gp_cv);
+ gp->gp_cv = Nullcv;
+ gp->gp_cvgen = 0;
+ }
+ else {
+ /* Adding a new name to a subroutine invalidates method cache */
+ sub_generation++;
+ }
+ }
return gp;
-
}
void
warn("Attempt to free unreferenced glob pointers");
return;
}
+ if (gp->gp_cv) {
+ /* Deleting the name of a subroutine invalidates method cache */
+ sub_generation++;
+ }
if (--gp->gp_refcnt > 0) {
if (gp->gp_egv == gv)
gp->gp_egv = 0;
SvREFCNT_dec(gp->gp_av);
SvREFCNT_dec(gp->gp_hv);
SvREFCNT_dec(gp->gp_io);
- if ((cv = gp->gp_cv) && !GvCVGEN(gv))
- SvREFCNT_dec(cv);
+ SvREFCNT_dec(gp->gp_cv);
SvREFCNT_dec(gp->gp_form);
Safefree(gp);
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+ AMT amt;
- if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
- amtp->was_ok_sub == sub_generation)
- return HV_AMAGIC(stash)? TRUE: FALSE;
- gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
- if (amtp && amtp->table) {
+ if (mg && amtp->was_ok_am == amagic_generation
+ && amtp->was_ok_sub == sub_generation)
+ return AMT_AMAGIC(amtp);
+ if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
int i;
- for (i=1;i<NofAMmeth*2;i++) {
+ for (i=1; i<NofAMmeth; i++) {
if (amtp->table[i]) {
SvREFCNT_dec(amtp->table[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.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)))) {
int filled=0;
int i;
char *cp;
- AMT amt;
SV* sv;
SV** svp;
- GV** gvp;
-
-/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
- DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
-);
- return HV_AMAGIC(stash)? TRUE: FALSE;
- }*/
-
- amt.was_ok_am=amagic_generation;
- amt.was_ok_sub=sub_generation;
- amt.fallback=AMGfallNO;
/* Work with "fallback" key, which we assume to be first in AMG_names */
- if ((cp=((char**)(*AMG_names))[0]) &&
- (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
+ if (( cp = (char *)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*2;i++) {
- cv=0;
-
- if ( (cp=((char**)(*AMG_names))[i]) ) {
- svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
+ for (i = 1; i < NofAMmeth; i++) {
+ cv = 0;
+ cp = (char *)AMG_names[i];
+
+ svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
if (svp && ((sv = *svp) != &sv_undef)) {
switch (SvTYPE(sv)) {
default:
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- die("Not a subroutine reference in overload table");
+ croak("Not a subroutine reference in overload table");
return FALSE;
case SVt_PVCV:
- cv = (CV*)sv;
- break;
+ cv = (CV*)sv;
+ break;
case SVt_PVGV:
- if (!(cv = GvCV((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, TRUE);
- break;
+ if (!(cv = GvCVu((GV*)sv)))
+ cv = sv_2cv(sv, &stash, &gv, TRUE);
+ break;
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %.256s during blessing\n",
+ croak("Method for operation %s not found in package %.256s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
}
- }
- amt.table[i]=(CV*)SvREFCNT_inc(cv);
+#else
+ {
+ int filled = 0;
+ int i;
+ char *cp;
+ SV* sv = NULL;
+ SV** svp;
+
+ /* Work with "fallback" key, which we assume to be first in AMG_names */
+
+ if ( cp = (char *)AMG_names[0] ) {
+ /* Try to find via inheritance. */
+ gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
+ if (gv) sv = GvSV(gv);
+
+ if (!gv) goto no_table;
+ else 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];
+
+ *buf = '('; /* A cookie: "(". */
+ strcpy(buf + 1, cp);
+ DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
+ cp, HvNAME(stash)) );
+ gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */
+ if(gv && (cv = GvCV(gv))) {
+ char *name = buf;
+ if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+ /* GvSV contains the name of the method. */
+ GV *ngv;
+
+ DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
+ SvPV(GvSV(gv), na), cp, HvNAME(stash)) );
+ if (SvPOK(GvSV(gv))
+ && (ngv = gv_fetchmethod(stash, SvPVX(GvSV(gv))))) {
+ name = SvPVX(GvSV(gv));
+ cv = GvCV(gv = ngv);
+ } else {
+ /* Can be an import stub (created by `can'). */
+ if (GvCVGEN(gv)) {
+ croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ } else
+ croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ }
+ /* If the sub is only a stub then we may have a gv to AUTOLOAD */
+ gv = (GV*)*hv_fetch(GvSTASH(gv), name, strlen(name), TRUE);
+ cv = GvCV(gv);
+ }
+ DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
+ cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
+ GvNAME(CvGV(cv))) );
+ filled = 1;
+ }
+#endif
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
if (filled) {
-/* HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_on(stash);
+ AMT_AMAGIC_on(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
return TRUE;
}
}
-/*HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_off(stash);
+ /* Here we have no table: */
+ no_table:
+ AMT_AMAGIC_off(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
return FALSE;
}
HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
- && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
+ && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
- && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
+ && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
goto not_found;
}
} else {
- not_found: /* No method found, either report or die */
+ not_found: /* No method found, either report or croak */
if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
} else {
- if (off==-1) off=method;
- sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
- ((char**)AMG_names)[method + assignshift],
+ if (off==-1) off=method;
+ sprintf(buf,
+ "Operation `%s': no method found,%sargument %s%.256s%s%.256s",
+ AMG_names[method + assignshift],
+ (flags & AMGf_unary ? " " : "\n\tleft "),
SvAMAGIC(left)?
"in overloaded package ":
"has no overloaded magic",
HvNAME(SvSTASH(SvRV(left))):
"",
SvAMAGIC(right)?
- "in overloaded package ":
- "has no overloaded magic",
+ ",\n\tright argument in overloaded package ":
+ (flags & AMGf_unary
+ ? ""
+ : ",\n\tright argument has no overloaded magic"),
SvAMAGIC(right)?
HvNAME(SvSTASH(SvRV(right))):
"");
if (amtp && amtp->fallback >= AMGfallYES) {
DEBUG_o( deb(buf) );
} else {
- die(buf);
+ croak(buf);
}
return NULL;
}
}
}
if (!notfound) {
- DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
- ((char**)AMG_names)[off],
+ DEBUG_o( deb(
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
+ AMG_names[off],
method+assignshift==off? "" :
" (initially `",
method+assignshift==off? "" :
- ((char**)AMG_names)[method+assignshift],
+ AMG_names[method+assignshift],
method+assignshift==off? "" : "')",
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
PUSHs(lr>0? left: right);
PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) );
+ PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
res=POPs;
PUTBACK;
- if (notfound) {
- /* sv_2mortal(res); */
- return NULL;
- }
-
if (postpr) {
int ans;
switch (method) {
case dec_amg:
SvSetSV(left,res); return left;
case not_amg:
-ans=!SvOK(res); break;
+ ans=!SvOK(res); break;
}
return ans? &sv_yes: &sv_no;
} else if (method==copy_amg) {
if (!SvROK(res)) {
- die("Copy method did not return a reference");
+ croak("Copy method did not return a reference");
}
return SvREFCNT_inc(SvRV(res));
} else {
projects / p5sagit/p5-mst-13.2.git / blobdiff