gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
sv_setpv(GvSV(gv), name);
if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
if (perldb)
hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
return gv;
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
}
static void
GV* gv;
GV** gvp;
HV* lastchance;
+ CV* cv;
if (!stash)
return 0;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
- if (GvCV(topgv)) {
- if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
+ 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;
+ 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))) {
}
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;
if (!level) {
if (lastchance = gv_stashpv("UNIVERSAL", 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);
+ }
GvCV(topgv) = GvCV(gv); /* cache the CV */
GvCVGEN(topgv) = sub_generation; /* valid for now */
return gv;
if (*nsplit == ':')
--nsplit;
*nsplit = '\0';
- stash = gv_stashpv(origname,TRUE);
- *nsplit = ch;
+ if (strEQ(origname,"SUPER")) {
+ /* Degenerate case ->SUPER::method should really lookup in original stash */
+ SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
+ sv_catpvn(tmpstr, "::SUPER", 7);
+ stash = gv_stashpv(SvPV(tmpstr,na),TRUE);
+ *nsplit = ch;
+ DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
+ } else {
+ stash = gv_stashpv(origname,TRUE);
+ *nsplit = ch;
+ }
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
+
+ if (!gv) {
+ /* Failed obvious case - look for SUPER as last element of stash's name */
+ char *packname = HvNAME(stash);
+ STRLEN len = strlen(packname);
+ if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
+ /* Now look for @.*::SUPER::ISA */
+ GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+ if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
+ /* No @ISA in package ending in ::SUPER - drop suffix
+ and see if there is an @ISA there
+ */
+ HV *basestash;
+ char ch = packname[len-7];
+ AV *av;
+ packname[len-7] = '\0';
+ basestash = gv_stashpv(packname, TRUE);
+ packname[len-7] = ch;
+ gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ /* Okay found @ISA after dropping the SUPER, alias it */
+ SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
+ sv_catpvn(tmpstr, "::ISA", 5);
+ gv = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV);
+ if (gv) {
+ GvAV(gv) = (AV*)SvREFCNT_inc(av);
+ /* ... and re-try lookup */
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
+ } else {
+ croak("Cannot create %s::ISA",HvNAME(stash));
+ }
+ }
+ }
+ }
+ }
+
if (!gv) {
CV* cv;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
if (gv && (cv = GvCV(gv))) { /* One more chance... */
- SV *tmpstr = sv_newmortal();
- sv_catpv(tmpstr,HvNAME(stash));
+ SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
sv_catpvn(tmpstr,"::", 2);
sv_catpvn(tmpstr, name, nend - name);
sv_setsv(GvSV(CvGV(cv)), tmpstr);
+ if (tainting)
+ sv_unmagic(GvSV(CvGV(cv)), 't');
}
}
}
char tmpbuf[1234];
HV *stash;
GV *tmpgv;
- sprintf(tmpbuf,"%.*s::",1200,name);
+ /* Use strncpy to avoid bug in VMS sprintf */
+ /* sprintf(tmpbuf,"%.*s::",1200,name); */
+ strncpy(tmpbuf, name, 1200);
+ tmpbuf[1200] = '\0'; /* just in case . . . */
+ strcat(tmpbuf, "::");
tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
if (!tmpgv)
return 0;
bool global = FALSE;
char *tmpbuf;
+ if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
+ name++;
+
for (namend = name; *namend; namend++) {
if ((*namend == '\'' && namend[1]) ||
(*namend == ':' && namend[1] == ':'))
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
else if (!add)
return Nullgv;
else
stash = defstash;
else if ((COP*)curcop == &compiling) {
stash = curstash;
- if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) {
- if (stash && !hv_fetch(stash,name,len,0))
+ if (add && (hints & HINT_STRICT_VARS) &&
+ sv_type != SVt_PVCV &&
+ sv_type != SVt_PVGV &&
+ sv_type != SVt_PVFM &&
+ sv_type != SVt_PVIO &&
+ !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
+ {
+ gvp = (GV**)hv_fetch(stash,name,len,0);
+ if (!gvp ||
+ *gvp == (GV*)&sv_undef ||
+ SvTYPE(*gvp) != SVt_PVGV)
+ {
stash = 0;
+ }
+ else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) ||
+ sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
+ sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
+ {
+ warn("Variable \"%c%s\" is not imported",
+ sv_type == SVt_PVAV ? '@' :
+ sv_type == SVt_PVHV ? '%' : '$',
+ name);
+ if (GvCV(*gvp))
+ warn("(Did you mean &%s instead?)\n", name);
+ stash = 0;
+ }
}
}
else
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
gv_init_sv(gv, sv_type);
}
return gv;
case 'a':
case 'b':
if (len == 1)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
break;
case 'E':
if (strnEQ(name, "EXPORT", 6))
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
break;
case 'I':
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
{
case 'O':
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
}
break;
if (strEQ(name, "SIG")) {
HV *hv;
siggv = gv;
- SvMULTI_on(siggv);
+ GvMULTI_on(siggv);
hv = GvHVn(siggv);
hv_magic(hv, siggv, 'S');
case '\\':
case '/':
case '|':
+ case '\001':
case '\004':
+ case '\005':
+ case '\006':
case '\010':
+ case '\017':
case '\t':
case '\020':
case '\024':
case '\027':
- case '\006':
if (len > 1)
break;
goto magicalize;
GV *gv;
{
GV* egv = GvEGV(gv);
- HV *hv = GvSTASH(egv);
-
+ HV *hv;
+
+ if (!egv)
+ egv = gv;
+ hv = GvSTASH(egv);
if (!hv)
return;
+
sv_setpv(sv, sv == (SV*)gv ? "*" : "");
sv_catpv(sv,HvNAME(hv));
sv_catpvn(sv,"::", 2);
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
- iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
+ iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
}
}
else if (isALPHA(*entry->hent_key)) {
gv = (GV*)entry->hent_val;
- if (SvMULTI(gv))
+ if (GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
filegv = GvFILEGV(gv);
curcop->cop_filegv = filegv;
- if (filegv && SvMULTI(filegv)) /* Filename began with slash */
+ if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
warn("Identifier \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
gp_free(gv)
GV* gv;
{
- IO *io;
- CV *cv;
GP* gp;
+ CV* cv;
if (!gv || !(gp = GvGP(gv)))
return;
warn("Attempt to free unreferenced glob pointers");
return;
}
- if (--gp->gp_refcnt > 0)
+ if (--gp->gp_refcnt > 0) {
+ if (gp->gp_egv == gv)
+ gp->gp_egv = 0;
return;
+ }
SvREFCNT_dec(gp->gp_sv);
SvREFCNT_dec(gp->gp_av);
SvREFCNT_dec(gp->gp_hv);
- if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
- do_close(gv,FALSE);
- SvREFCNT_dec(io);
- }
+ SvREFCNT_dec(gp->gp_io);
if ((cv = gp->gp_cv) && !GvCVGEN(gv))
SvREFCNT_dec(cv);
+ SvREFCNT_dec(gp->gp_form);
+
Safefree(gp);
GvGP(gv) = 0;
}
GV* gv;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
- AMT *amtp;
+ AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
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) {
+ int i;
+ for (i=1;i<NofAMmeth*2;i++) {
+ if (amtp->table[i]) {
+ SvREFCNT_dec(amtp->table[i]);
+ }
+ }
+ }
sv_unmagic((SV*)stash, 'c');
DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
default:
if (!SvROK(sv)) {
if (!SvOK(sv)) break;
- gv = gv_fetchmethod(curcop->cop_stash, SvPV(sv, na));
+ gv = gv_fetchmethod(stash, SvPV(sv, na));
if (gv) cv = GvCV(gv);
break;
}
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %s during blessing\n",
+ die("Method for operation %s not found in package %.256s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
}
}
- amt.table[i]=cv;
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
if (filled) {
CV **cvp=NULL, **ocvp=NULL;
AMT *amtp, *oamtp;
int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
- int postpr=0;
+ int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
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))
- && (assign ?
- ((cv = cvp[off=method+1])
- || ( amtp->fallback > AMGfallNEVER && /* fallback to
- * usual method */
- (fl = 1, cv = cvp[off=method]))):
- (1 && (cv = cvp[off=method])) )) {
+ && ((cv = cvp[off=method+assignshift])
+ || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+ * usual method */
+ (fl = 1, cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
/* look for substituted methods */
switch (method) {
case inc_amg:
- if ((cv = cvp[off=add_ass_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;
}
break;
case dec_amg:
- if ((cv = cvp[off=subtr_ass_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;
}
case string_amg:
(void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
break;
+ case copy_amg:
+ {
+ SV* ref=SvRV(left);
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
+ * extra
+ * causious,
+ * maybe in some
+ * additional
+ * cases sv_setsv
+ * is safe too */
+ SV* newref = newSVsv(ref);
+ SvOBJECT_on(newref);
+ SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
+ return newref;
+ }
+ }
+ break;
case abs_amg:
- if ((cvp[off1=lt_amg] || cvp[off1=lt_amg])
+ if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
&& ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
+ SV* nullsv=sv_2mortal(newSViv(0));
if (off1==lt_amg) {
- SV* lessp = amagic_call(left,
- sv_2mortal(newSViv(0)),
+ SV* lessp = amagic_call(left,nullsv,
lt_amg,AMGf_noright);
logic = SvTRUE(lessp);
} else {
- SV* lessp = amagic_call(left,
- sv_2mortal(newSViv(0)),
+ SV* lessp = amagic_call(left,nullsv,
ncmp_amg,AMGf_noright);
logic = (SvNV(lessp) < 0);
}
if (logic) {
if (off==subtr_amg) {
right = left;
- left = sv_2mortal(newSViv(0));
+ left = nullsv;
lr = 1;
}
} else {
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
- } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp))
+ } else if (((ocvp && oamtp->fallback > AMGfallNEVER
+ && (cvp=ocvp) && (lr = -1))
|| (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
&& !(flags & AMGf_unary)) {
/* We look for substitution for
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
} else {
- char tmpstr[512];
- sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s",
- ((char**)AMG_names)[off],
+ 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],
SvAMAGIC(left)?
"in overloaded package ":
"has no overloaded magic",
HvNAME(SvSTASH(SvRV(right))):
"");
if (amtp && amtp->fallback >= AMGfallYES) {
- DEBUG_o( deb(tmpstr) );
+ DEBUG_o( deb(buf) );
} else {
- die(tmpstr);
+ die(buf);
}
return NULL;
}
}
}
if (!notfound) {
- DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n",
+ DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
((char**)AMG_names)[off],
- (lr? "right": "left"),
+ method+assignshift==off? "" :
+ " (initially `",
+ method+assignshift==off? "" :
+ ((char**)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, we need to dublicate the contents,
- probably we need also to use user-supplied version of coping?
- */
- if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left);
+ /* 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);
}
{
dSP;
PUSHs(lr>0? left: right);
PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) );
+ PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
if (op = pp_entersub())
- run();
+ runops();
LEAVE;
SPAGAIN;
SvSetSV(left,res); return res; break;
}
return ans? &sv_yes: &sv_no;
+ } else if (method==copy_amg) {
+ if (!SvROK(res)) {
+ die("Copy method did not return a reference");
+ }
+ return SvREFCNT_inc(SvRV(res));
} else {
return res;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff