X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=eaf2ab11f62cf1dfa831ea5db544e1fdc74ce294;hb=71a29c3c6e68e84b4c2fa366c4878918712829a9;hp=ec23d9031560c234230f7e15413ee9f0002b00ca;hpb=8990e3071044a96302560bbdb5706f3e74cf1bef;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index ec23d90..eaf2ab1 100644 --- a/gv.c +++ b/gv.c @@ -1,214 +1,570 @@ -/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $ +/* gv.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: gv.c,v $ - * Revision 4.1 92/08/07 18:26:39 lwall - * - * Revision 4.0.1.4 92/06/08 15:32:19 lwall - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: the debugger now warns you on lines that can't set a breakpoint - * patch20: the debugger made perl forget the last pattern used by // - * patch20: paragraph mode now skips extra newlines automatically - * patch20: ($<,$>) = ... didn't work on some architectures - * - * Revision 4.0.1.3 91/11/05 18:35:33 lwall - * patch11: length($x) was sometimes wrong for numeric $x - * patch11: perl now issues warning if $SIG{'ALARM'} is referenced - * patch11: *foo = undef coredumped - * patch11: solitary subroutine references no longer trigger typo warnings - * patch11: local(*FILEHANDLE) had a memory leak - * - * Revision 4.0.1.2 91/06/07 11:55:53 lwall - * patch4: new copyright notice - * patch4: added $^P variable to control calling of perldb routines - * patch4: added $^F variable to specify maximum system fd, default 2 - * patch4: $` was busted inside s/// - * patch4: default top-of-form run_format is now FILEHANDLE_TOP - * patch4: length($`), length($&), length($') now optimized to avoid string copy - * patch4: $^D |= 1024 now does syntax tree dump at run-time - * - * Revision 4.0.1.1 91/04/12 09:10:24 lwall - * patch1: Configure now differentiates getgroups() type from getgid() type - * patch1: you may now use "die" and "caller" in a signal handler - * - * Revision 4.0 91/03/20 01:39:41 lwall - * 4.0 baseline. - * + */ + +/* + * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure + * of your inquisitiveness, I shall spend all the rest of my days answering + * you. What more do you want to know?' + * 'The names of all the stars, and of all living things, and the whole + * history of Middle-earth and Over-heaven and of the Sundering Seas,' + * laughed Pippin. */ #include "EXTERN.h" +#define PERL_IN_GV_C #include "perl.h" -extern char rcsid[]; - GV * -gv_AVadd(gv) -register GV *gv; +Perl_gv_AVadd(pTHX_ register GV *gv) { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + Perl_croak(aTHX_ "Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); return gv; } GV * -gv_HVadd(gv) -register GV *gv; +Perl_gv_HVadd(pTHX_ register GV *gv) { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + Perl_croak(aTHX_ "Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); return gv; } GV * -gv_fetchfile(name) -char *name; +Perl_gv_IOadd(pTHX_ register GV *gv) +{ + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + Perl_croak(aTHX_ "Bad symbol for filehandle"); + if (!GvIOp(gv)) + GvIOp(gv) = newIO(); + return gv; +} + +GV * +Perl_gv_fetchfile(pTHX_ const char *name) { - char tmpbuf[1200]; + dTHR; + char smallbuf[256]; + char *tmpbuf; + STRLEN tmplen; GV *gv; - sprintf(tmpbuf,"::_<%s", name); - gv = gv_fetchpv(tmpbuf, TRUE); - sv_setpv(GvSV(gv), name); - if (*name == '/') - SvMULTI_on(gv); - if (perldb) - hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); + if (!PL_defstash) + return Nullgv; + + tmplen = strlen(name) + 2; + if (tmplen < sizeof smallbuf) + tmpbuf = smallbuf; + else + New(603, tmpbuf, tmplen + 1, char); + tmpbuf[0] = '_'; + tmpbuf[1] = '<'; + strcpy(tmpbuf + 2, name); + gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); + if (!isGV(gv)) { + gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + sv_setpv(GvSV(gv), name); + if (PERLDB_LINE) + hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); + } + if (tmpbuf != smallbuf) + Safefree(tmpbuf); return gv; } void -gv_init(gv, stash, name, len, multi) -GV *gv; -HV *stash; -char *name; -STRLEN len; -int multi; +Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { + dTHR; register GP *gp; + bool doproto = SvTYPE(gv) > SVt_NULL; + char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; - sv_upgrade(gv, SVt_PVGV); - if (SvLEN(gv)) - Safefree(SvPVX(gv)); - Newz(602,gp, 1, GP); + sv_upgrade((SV*)gv, SVt_PVGV); + 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); - GvREFCNT(gv) = 1; GvSV(gv) = NEWSV(72,0); - GvLINE(gv) = curcop->cop_line; - GvFILEGV(gv) = curcop->cop_filegv; + GvLINE(gv) = CopLINE(PL_curcop); + GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; + GvCVGEN(gv) = 0; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); - GvSTASH(gv) = stash; - GvNAME(gv) = nsavestr(name, len); + GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); + GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; - if (multi) - SvMULTI_on(gv); + if (multi || doproto) /* doproto means it _was_ mentioned */ + GvMULTI_on(gv); + if (doproto) { /* Replicate part of newSUB here. */ + SvIOK_off(gv); + ENTER; + /* XXX unsafe for threads if eval_owner isn't held */ + start_subparse(0,0); /* Create CV in compcv. */ + GvCV(gv) = PL_compcv; + LEAVE; + + PL_sub_generation++; + CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); + CvFILE(GvCV(gv)) = CopFILE(PL_curcop); + 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 +S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) +{ + switch (sv_type) { + case SVt_PVIO: + (void)GvIOn(gv); + break; + case SVt_PVAV: + (void)GvAVn(gv); + break; + case SVt_PVHV: + (void)GvHVn(gv); + break; + } +} + +/* +=for apidoc gv_fetchmeth + +Returns the glob with the given C and a defined subroutine or +C. The glob lives in the given C, or in the stashes +accessible via @ISA and @UNIVERSAL. + +The argument C should be either 0 or -1. If C, as a +side-effect creates a glob with the given C in the given C +which in the case of success contains an alias for the subroutine, and sets +up caching info for this glob. Similarly for all the searched stashes. + +This function grants C<"SUPER"> token as a postfix of the stash name. The +GV returned from C may be a method cache entry, which is not +visible to Perl code. So when calling C, you should not use +the GV directly; instead, you should use the method's CV, which can be +obtained from the GV with the C macro. + +=cut +*/ + GV * -gv_fetchmeth(stash, name, len) -HV* stash; -char* name; -STRLEN len; +Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { AV* av; GV* topgv; GV* gv; GV** gvp; + CV* cv; - gvp = (GV**)hv_fetch(stash, name, len, TRUE); + 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( 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); + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); - if (GvCV(topgv)) { - if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) - return topgv; + 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); - if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + 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))) { + dTHR; /* just for SvREFCNT_dec */ + 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); - I32 items = AvFILL(av) + 1; + /* NOTE: No support for tied ISA */ + I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; - HV* basestash = fetch_stash(sv, FALSE); + 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)) + Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len); - if (gv) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ + 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; } +/* +=for apidoc gv_fetchmethod + +See L. + +=cut +*/ + +GV * +Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) +{ + return gv_fetchmethod_autoload(stash, name, TRUE); +} + +/* +=for apidoc gv_fetchmethod_autoload + +Returns the glob which contains the subroutine to call to invoke the method +on the C. In fact in the presence of autoloading this may be the +glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is +already setup. + +The third parameter of C determines whether +AUTOLOAD lookup is performed if the given method is not present: non-zero +means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. +Calling C is equivalent to calling C +with a non-zero C parameter. + +These functions grant C<"SUPER"> token as a prefix of the method name. Note +that if you want to keep the returned glob for a long time, you need to +check for it being "AUTOLOAD", since at the later time the call may load a +different subroutine due to $AUTOLOAD changing its value. Use the glob +created via a side effect to do this. + +These functions have the same side-effects and as C with +C. C should be writable if contains C<':'> or C<' +''>. The warning against passing the GV returned by C to +C apply equally to these functions. + +=cut +*/ + GV * -gv_fetchmethod(stash, name) -HV* stash; -char* name; +Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { - register char *nend; + dTHR; + register const char *nend; + const char *nsplit = 0; + GV* gv; for (nend = name; *nend; nend++) { - if (*nend == ':' || *nend == '\'') { - return gv_fetchpv(name, FALSE); + 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")) + 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_fetchmeth(stash, name, nend - name); + + return gv; } +GV* +Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) +{ + dTHR; + 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, FALSE))) + return Nullgv; + cv = GvCV(gv); + + /* + * 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); + 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; +} + +/* +=for apidoc gv_stashpv + +Returns a pointer to the stash for a specified package. C should +be a valid UTF-8 string. If C is set then the package will be +created if it does not already exist. If C is not set and the +package does not exist then NULL is returned. + +=cut +*/ + +HV* +Perl_gv_stashpv(pTHX_ const char *name, I32 create) +{ + return gv_stashpvn(name, strlen(name), create); +} + +HV* +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) +{ + char smallbuf[256]; + char *tmpbuf; + HV *stash; + GV *tmpgv; + + if (namelen + 3 < sizeof smallbuf) + tmpbuf = smallbuf; + else + New(606, tmpbuf, namelen + 3, char); + Copy(name,tmpbuf,namelen,char); + tmpbuf[namelen++] = ':'; + tmpbuf[namelen++] = ':'; + tmpbuf[namelen] = '\0'; + tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); + if (tmpbuf != smallbuf) + Safefree(tmpbuf); + if (!tmpgv) + return 0; + if (!GvHV(tmpgv)) + GvHV(tmpgv) = newHV(); + stash = GvHV(tmpgv); + if (!HvNAME(stash)) + HvNAME(stash) = savepv(name); + return stash; +} + +/* +=for apidoc gv_stashsv + +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C. + +=cut +*/ + +HV* +Perl_gv_stashsv(pTHX_ SV *sv, I32 create) +{ + register char *ptr; + STRLEN len; + ptr = SvPV(sv,len); + return gv_stashpvn(ptr, len, create); +} + + GV * -gv_fetchpv(nambeg,add) -char *nambeg; -I32 add; +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - register char *name = nambeg; + dTHR; + register const char *name = nambeg; register GV *gv = 0; GV**gvp; I32 len; - register char *namend; + register const char *namend; HV *stash = 0; - bool global = FALSE; - char tmpbuf[256]; + U32 add_gvflags = 0; + + if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ + name++; for (namend = name; *namend; namend++) { - if ((*namend == '\'' && namend[1]) || - (*namend == ':' && namend[1] == ':')) + if ((*namend == ':' && namend[1] == ':') + || (*namend == '\'' && namend[1])) { - len = namend - name; - *tmpbuf = '_'; - Copy(name, tmpbuf+1, len, char); - len++; - tmpbuf[len] = '\0'; if (!stash) - stash = defstash; + stash = PL_defstash; + if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ + return Nullgv; - if (len > 1) { + len = namend - name; + if (len > 0) { + 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); - if (!gvp || *gvp == (GV*)&sv_undef) + 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; - gv = *gvp; - if (SvTYPE(gv) == SVt_PVGV) - SvMULTI_on(gv); - else - gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); + if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); + if (!HvNAME(stash)) - HvNAME(stash) = nsavestr(nambeg, namend - nambeg); + HvNAME(stash) = savepvn(nambeg, namend - nambeg); } if (*namend == ':') @@ -216,137 +572,254 @@ I32 add; namend++; name = namend; if (!*name) - return gv ? gv : defgv; + return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); } } + len = namend - name; + if (!len) + len = 1; /* No stash in name, so see how we can default */ if (!stash) { - if (isIDFIRST(*name)) { + if (isIDFIRST_lazy(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; + 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 && + 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*)&PL_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)) ) + { + Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", + sv_type == SVt_PVAV ? '@' : + sv_type == SVt_PVHV ? '%' : '$', + name); + if (GvCVu(*gvp)) + Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name); + stash = 0; + } + } + } else - stash = curcop->cop_stash; + stash = CopSTASH(PL_curcop); } else - stash = defstash; + stash = PL_defstash; } /* By this point we should have a stash and a name */ - if (!stash) - croak("Global symbol \"%s\" requires explicit package name", name); - len = namend - name; - if (!len) - len = 1; + if (!stash) { + if (add) { + qerror(Perl_mess(aTHX_ + "Global symbol \"%s%s\" requires explicit package name", + (sv_type == SVt_PV ? "$" + : sv_type == SVt_PVAV ? "@" + : sv_type == SVt_PVHV ? "%" + : ""), name)); + } + return Nullgv; + } + + 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) { - SvMULTI_on(gv); + if (add) { + GvMULTI_on(gv); + gv_init_sv(gv, sv_type); + } + return gv; + } else if (add & GV_NOINIT) { return gv; } /* Adding a new symbol */ - gv_init(gv, stash, name, len, add & 2); + if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); + gv_init(gv, stash, name, len, add & GV_ADDMULTI); + gv_init_sv(gv, sv_type); + GvFLAGS(gv) |= add_gvflags; + + if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) + GvMULTI_on(gv) ; /* set up magic where warranted */ switch (*name) { - case 'a': - case 'b': - if (len == 1) - SvMULTI_on(gv); + case 'A': + if (strEQ(name, "ARGV")) { + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } + break; + case 'E': + if (strnEQ(name, "EXPORT", 6)) + GvMULTI_on(gv); break; case 'I': if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); - SvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, 'I', 0, 0); + GvMULTI_on(gv); + sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); + /* NOTE: No support for tied ISA */ + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) + { + char *pname; + av_push(av, newSVpvn(pname = "NDBM_File",9)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpvn(pname = "DB_File",7)); + gv_stashpvn(pname, 7, TRUE); + av_push(av, newSVpvn(pname = "GDBM_File",9)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpvn(pname = "SDBM_File",9)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpvn(pname = "ODBM_File",9)); + gv_stashpvn(pname, 9, TRUE); + } } break; + case 'O': + if (strEQ(name, "OVERLOAD")) { + HV* hv = GvHVn(gv); + GvMULTI_on(gv); + hv_magic(hv, gv, 'A'); + } + break; case 'S': if (strEQ(name, "SIG")) { HV *hv; - siggv = gv; - SvMULTI_on(siggv); - hv = GvHVn(siggv); - hv_magic(hv, siggv, 'S'); - - /* initialize signal stack */ - signalstack = newAV(); - av_store(signalstack, 32, Nullsv); - av_clear(signalstack); - AvREAL_off(signalstack); + I32 i; + if (!PL_psig_ptr) { + int sig_num[] = { SIG_NUM }; + New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + } + GvMULTI_on(gv); + hv = GvHVn(gv); + hv_magic(hv, gv, 'S'); + for (i = 1; PL_sig_name[i]; i++) { + SV ** init; + init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); + if (init) + sv_setsv(*init, &PL_sv_undef); + PL_psig_ptr[i] = 0; + PL_psig_name[i] = 0; + } } break; + case 'V': + if (strEQ(name, "VERSION")) + GvMULTI_on(gv); + break; case '&': if (len > 1) break; - ampergv = gv; - sawampersand = TRUE; - goto magicalize; + PL_sawampersand = TRUE; + goto ro_magicalize; case '`': if (len > 1) break; - leftgv = gv; - sawampersand = TRUE; - goto magicalize; + PL_sawampersand = TRUE; + goto ro_magicalize; case '\'': if (len > 1) break; - rightgv = gv; - sawampersand = TRUE; - goto magicalize; + 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 + (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; + require_pv("Errno.pm"); + SPAGAIN; + stash = gv_stashpvn("Errno",5,FALSE); + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) + Perl_croak(aTHX_ "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 '?': + case '*': + if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) + Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name); + /* FALL THROUGH */ + case '[': case '^': case '~': case '=': - case '-': case '%': case '.': - case '+': - case '*': case '(': case ')': case '<': @@ -354,18 +827,38 @@ I32 add; case ',': case '\\': case '/': - case '[': case '|': - case '\004': - case '\t': - case '\020': - case '\024': - case '\027': - case '\006': + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\010': /* $^H */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\024': /* $^T */ + if (len > 1) + break; + goto magicalize; + case '\023': /* $^S */ if (len > 1) break; + goto ro_magicalize; + case '\027': /* $^W & $^WARNING_BITS */ + if (len > 1 && strNE(name, "\027ARNING_BITS") + && strNE(name, "\027IDE_SYSTEM_CALLS")) + break; goto 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': @@ -375,15 +868,17 @@ I32 add; case '7': case '8': case '9': + ro_magicalize: + SvREADONLY_on(GvSV(gv)); magicalize: sv_magic(GvSV(gv), (SV*)gv, 0, name, len); break; - case '\014': + case '\014': /* $^L */ if (len > 1) break; sv_setpv(GvSV(gv),"\f"); - formfeed = GvSV(gv); + PL_formfeed = GvSV(gv); break; case ';': if (len > 1) @@ -392,12 +887,19 @@ I32 add; break; case ']': if (len == 1) { - SV *sv; - sv = GvSV(gv); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv,rcsid); - SvNVX(sv) = atof(patchlevel); + SV *sv = GvSV(gv); + (void)SvUPGRADE(sv, SVt_PVNV); + SvNVX(sv) = SvNVX(PL_patchlevel); SvNOK_on(sv); + (void)SvPV_nolen(sv); + SvREADONLY_on(sv); + } + break; + case '\026': /* $^V */ + if (len == 1) { + SV *sv = GvSV(gv); + GvSV(gv) = SvREFCNT_inc(PL_patchlevel); + SvREFCNT_dec(sv); } break; } @@ -405,55 +907,65 @@ I32 add; } void -gv_fullname(sv,gv) -SV *sv; -GV *gv; +Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { HV *hv = GvSTASH(gv); - - if (!hv) + if (!hv) { + (void)SvOK_off(sv); return; - sv_setpv(sv, sv == (SV*)gv ? "*" : ""); + } + sv_setpv(sv, prefix ? prefix : ""); sv_catpv(sv,HvNAME(hv)); sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void -gv_efullname(sv,gv) -SV *sv; -GV *gv; +Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { - GV* egv = GvEGV(gv); - HV *hv = GvSTASH(egv); + GV *egv = GvEGV(gv); + if (!egv) + egv = gv; + gv_fullname3(sv, egv, prefix); +} - if (!hv) - return; - sv_setpv(sv, sv == (SV*)gv ? "*" : ""); - sv_catpv(sv,HvNAME(hv)); - sv_catpvn(sv,"::", 2); - sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv)); +/* XXX compatibility with versions <= 5.003. */ +void +Perl_gv_fullname(pTHX_ SV *sv, GV *gv) +{ + gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); +} + +/* XXX compatibility with versions <= 5.003. */ +void +Perl_gv_efullname(pTHX_ SV *sv, GV *gv) +{ + gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); } IO * -newIO() +Perl_newIO(pTHX) { + dTHR; IO *io; GV *iogv; io = (IO*)NEWSV(0,0); - sv_upgrade(io,SVt_PVIO); + sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - iogv = gv_fetchpv("FileHandle::", TRUE); + iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); + /* 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; } void -gv_check(stash) -HV* stash; +Perl_gv_check(pTHX_ HV *stash) { + dTHR; register HE *entry; register I32 i; register GV *gv; @@ -461,71 +973,103 @@ HV* stash; if (!HvARRAY(stash)) return; - for (i = 0; i <= HvMAX(stash); i++) { - for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { - if (isALPHA(*entry->hent_key)) { - gv = (GV*)entry->hent_val; - if (SvMULTI(gv)) + for (i = 0; i <= (I32) HvMAX(stash); i++) { + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && + (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) + { + if (hv != PL_defstash && hv != stash) + gv_check(hv); /* nested package */ + } + else if (isALPHA(*HeKEY(entry))) { + char *file; + gv = (GV*)HeVAL(entry); + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; - curcop->cop_line = GvLINE(gv); - curcop->cop_filegv = GvFILEGV(gv); - if (SvMULTI(GvFILEGV(gv))) /* Filename began with slash */ + file = GvFILE(gv); + /* performance hack: if filename is absolute and it's a standard + * module, don't bother warning */ + if (file + && PERL_FILE_IS_ABSOLUTE(file) + && (instr(file, "/lib/") || instr(file, ".pm"))) + { continue; - warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv)); + } + CopLINE_set(PL_curcop, GvLINE(gv)); +#ifdef USE_ITHREADS + CopFILE(PL_curcop) = file; /* set for warning */ +#else + CopFILEGV(PL_curcop) = gv_fetchfile(file); +#endif + Perl_warner(aTHX_ WARN_ONCE, + "Name \"%s::%s\" used only once: possible typo", + HvNAME(stash), GvNAME(gv)); } - else if (*entry->hent_key == '_' && - (gv = (GV*)entry->hent_val) && - (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) - gv_check(hv); /* nested package */ - } } } GV * -newGVgen() +Perl_newGVgen(pTHX_ char *pack) { - (void)sprintf(tokenbuf,"_GEN_%d",gensym++); - return gv_fetchpv(tokenbuf,TRUE); + return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), + TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ GP* -gp_ref(gp) -GP* gp; +Perl_gp_ref(pTHX_ GP *gp) { + if (!gp) + return (GP*)NULL; 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 */ + PL_sub_generation++; + } + } return gp; - } void -gp_free(gv) -GV* gv; +Perl_gp_free(pTHX_ GV *gv) { - IO *io; - CV *cv; + dTHR; GP* gp; if (!gv || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { - warn("Attempt to free unreferenced glob pointers"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, + "Attempt to free unreferenced glob pointers"); return; } - if (--gp->gp_refcnt > 0) + if (gp->gp_cv) { + /* Deleting the name of a subroutine invalidates method cache */ + PL_sub_generation++; + } + 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); - } - if ((cv = gp->gp_cv) && !GvCVGEN(gv)) - SvREFCNT_dec(cv); + SvREFCNT_dec(gp->gp_io); + SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec(gp->gp_form); + Safefree(gp); GvGP(gv) = 0; } @@ -554,35 +1098,485 @@ register GV *gv; } #endif /* Microport 2.4 hack */ -GV * -fetch_gv(op,num) -OP *op; -I32 num; +/* Updates and caches the CV's */ + +bool +Perl_Gv_AMupdate(pTHX_ HV *stash) { - if (op->op_private < num) - return 0; - if (op->op_flags & OPf_STACKED) - return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE); - else - return cGVOP->op_gv; + dTHR; + GV* gv; + CV* cv; + MAGIC* mg=mg_find((SV*)stash,'c'); + AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; + AMT amt; + STRLEN n_a; +#ifdef OVERLOAD_VIA_HASH + GV** gvp; + HV* hv; +#endif + + 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; + for (i=1; itable[i]) { + SvREFCNT_dec(amtp->table[i]); + } + } + } + sv_unmagic((SV*)stash, 'c'); + + DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + + 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*)&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 PL_AMG_names */ + + 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 *)PL_AMG_names[i]; + + svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); + if (svp && ((sv = *svp) != &PL_sv_undef)) { + switch (SvTYPE(sv)) { + default: + if (!SvROK(sv)) { + if (!SvOK(sv)) break; + gv = gv_fetchmethod(stash, SvPV(sv, n_a)); + if (gv) cv = GvCV(gv); + break; + } + cv = (CV*)SvRV(sv); + if (SvTYPE(cv) == SVt_PVCV) + break; + /* FALL THROUGH */ + case SVt_PVHV: + case SVt_PVAV: + Perl_croak(aTHX_ "Not a subroutine reference in overload table"); + return FALSE; + case SVt_PVCV: + cv = (CV*)sv; + break; + case SVt_PVGV: + if (!(cv = GvCVu((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, FALSE); + break; + } + if (cv) filled=1; + else { + Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n", + cp,HvNAME(stash)); + return FALSE; + } + } +#else + { + int filled = 0; + int i; + const char *cp; + SV* sv = NULL; + + /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ + + if ((cp = PL_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++) { + SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", + cp, HvNAME(stash)) ); + /* don't fill the cache while looking up! */ + gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + cv = 0; + if(gv && (cv = GvCV(gv))) { + 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( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", + SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); + if (!SvPOK(GvSV(gv)) + || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), + FALSE))) + { + /* Can be an import stub (created by `can'). */ + if (GvCVGEN(gv)) { + Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } else + Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } + cv = GvCV(gv = ngv); + } + DEBUG_o( Perl_deb(aTHX_ "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); + } + if (filled) { + AMT_AMAGIC_on(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); + return TRUE; + } + } + /* Here we have no table: */ + no_table: + AMT_AMAGIC_off(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); + return FALSE; } -IO * -fetch_io(op,num) -OP *op; -I32 num; +SV* +Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - GV *gv; + dTHR; + MAGIC *mg; + CV *cv; + CV **cvp=NULL, **ocvp=NULL; + AMT *amtp, *oamtp; + int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=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')) + && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : (CV **) NULL)) + && ((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) { + int logic; - if (op->op_private < num) - return 0; - if (op->op_flags & OPf_STACKED) - gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE); - else - gv = cGVOP->op_gv; + /* look for substituted methods */ + /* In all the covered cases we should be called with assign==0. */ + switch (method) { + case inc_amg: + 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: + 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: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); + break; + case numer_amg: + (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); + break; + case string_amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); + break; + case not_amg: + (void)((cv = cvp[off=bool__amg]) + || (cv = cvp[off=numer_amg]) + || (cv = cvp[off=string_amg])); + postpr = 1; + break; + case copy_amg: + { + /* + * 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(tmpRef); + SvOBJECT_on(newref); + SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef)); + return newref; + } + } + break; + case abs_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,nullsv, + lt_amg,AMGf_noright); + logic = SvTRUE(lessp); + } else { + SV* lessp = amagic_call(left,nullsv, + ncmp_amg,AMGf_noright); + logic = (SvNV(lessp) < 0); + } + if (logic) { + if (off==subtr_amg) { + right = left; + left = nullsv; + lr = 1; + } + } else { + return left; + } + } + break; + case neg_amg: + if ((cv = cvp[off=subtr_amg])) { + right = left; + left = sv_2mortal(newSViv(0)); + 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 (!cv) goto not_found; + } else if (!(AMGf_noright & flags) && SvAMAGIC(right) + && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (amtp = (AMT*)mg->mg_ptr)->table + : (CV **) NULL)) + && (cv = cvp[off=method])) { /* Method for right + * argument found */ + lr=1; + } else if (((ocvp && oamtp->fallback > AMGfallNEVER + && (cvp=ocvp) && (lr = -1)) + || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatenation */ + if (method==concat_amg || method==concat_ass_amg + || method==repeat_amg || method==repeat_ass_amg) { + return NULL; /* Delegate operation to string conversion */ + } + off = -1; + switch (method) { + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: + postpr = 1; off=ncmp_amg; break; + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: + postpr = 1; off=scmp_amg; break; + } + if (off != -1) cv = cvp[off]; + if (!cv) { + goto not_found; + } + } else { + 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 { + SV *msg; + if (off==-1) off=method; + msg = sv_2mortal(Perl_newSVpvf(aTHX_ + "Operation `%s': no method found,%sargument %s%s%s%s", + PL_AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + HvNAME(SvSTASH(SvRV(left))): + "", + SvAMAGIC(right)? + ",\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( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); + } else { + Perl_croak(aTHX_ "%"SVf, msg); + } + return NULL; + } + force_cpy = force_cpy || assign; + } + } + if (!notfound) { + DEBUG_o( Perl_deb(aTHX_ + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + PL_AMG_names[off], + method+assignshift==off? "" : + " (initially `", + method+assignshift==off? "" : + 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 + */ + /* 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); + { + dSP; + BINOP myop; + SV* res; + bool oldcatch = CATCH_GET; - if (!gv) - return 0; + CATCH_SET(TRUE); + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + + PUSHSTACKi(PERLSI_OVERLOAD); + ENTER; + SAVEOP(); + PL_op = (OP *) &myop; + if (PERLDB_SUB && PL_curstash != PL_debstash) + PL_op->op_private |= OPpENTERSUB_DB; + PUTBACK; + pp_pushmark(); + + EXTEND(SP, notfound + 5); + PUSHs(lr>0? right: left); + PUSHs(lr>0? left: right); + PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); + if (notfound) { + PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); + } + PUSHs((SV*)cv); + PUTBACK; - return GvIOn(gv); + if ((PL_op = Perl_pp_entersub(aTHX))) + CALLRUNOPS(aTHX); + LEAVE; + SPAGAIN; + + res=POPs; + PUTBACK; + POPSTACK; + CATCH_SET(oldcatch); + + if (postpr) { + int ans; + switch (method) { + case le_amg: + case sle_amg: + ans=SvIV(res)<=0; break; + case lt_amg: + case slt_amg: + ans=SvIV(res)<0; break; + case ge_amg: + case sge_amg: + ans=SvIV(res)>=0; break; + case gt_amg: + case sgt_amg: + ans=SvIV(res)>0; break; + case eq_amg: + case seq_amg: + ans=SvIV(res)==0; break; + case ne_amg: + case sne_amg: + ans=SvIV(res)!=0; break; + case inc_amg: + case dec_amg: + SvSetSV(left,res); return left; + case not_amg: + ans=!SvTRUE(res); break; + } + return boolSV(ans); + } else if (method==copy_amg) { + if (!SvROK(res)) { + Perl_croak(aTHX_ "Copy method did not return a reference"); + } + return SvREFCNT_inc(SvRV(res)); + } else { + return res; + } + } }