/* gv.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, 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.
gv_fetchfile(name)
char *name;
{
- char tmpbuf[1200];
+ dTHR;
+ char smallbuf[256];
+ char *tmpbuf;
STRLEN tmplen;
GV *gv;
- sprintf(tmpbuf, "_<%s", name);
- tmplen = strlen(tmpbuf);
+ 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(defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv))
gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
sv_setpv(GvSV(gv), name);
if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
GvMULTI_on(gv);
GV* topgv;
GV* gv;
GV** gvp;
- HV* lastchance;
CV* cv;
if (!stash)
}
}
- 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*)&sv_undef) ? GvAV(gv) : Nullav;
+
+ /* create @.*::SUPER::ISA on demand */
+ if (!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*)&sv_undef && (av = GvAV(gv))) {
+ dTHR; /* just for SvREFCNT_dec */
+ gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
+ if (!gvp || !(gv = *gvp))
+ croak("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;
while (items--) {
}
}
+ /* 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:
- /* Use topgv for cache only if it has no synonyms */
- if (topgv && GvREFCNT(topgv) == 1) {
+ /*
+ * 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)))
+ {
+ dTHR; /* just for SvREFCNT_inc */
if (cv = GvCV(topgv))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
HV* stash;
char* name;
{
+ return gv_fetchmethod_autoload(stash, name, TRUE);
+}
+
+GV *
+gv_fetchmethod_autoload(stash, name, autoload)
+HV* stash;
+char* name;
+I32 autoload;
+{
register char *nend;
char *nsplit = 0;
GV* gv;
for (nend = name; *nend; nend++) {
- if (*nend == ':' || *nend == '\'')
+ if (*nend == '\'')
nsplit = nend;
+ else if (*nend == ':' && *(nend + 1) == ':')
+ nsplit = ++nend;
}
if (nsplit) {
- char ch;
char *origname = name;
name = nsplit + 1;
- ch = *nsplit;
if (*nsplit == ':')
--nsplit;
- *nsplit = '\0';
- 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_stashpvn(SvPVX(tmpstr),SvCUR(tmpstr),TRUE);
- *nsplit = ch;
- DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
- } else {
- stash = gv_stashpvn(origname, nsplit - origname, TRUE);
- *nsplit = ch;
+ 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)));
+ 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) {
- /* 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);
- len -= 7;
- 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];
- AV *av;
- packname[len] = '\0';
- basestash = gv_stashpvn(packname, len, TRUE);
- packname[len] = 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));
- }
- }
- }
- }
+ else
+ stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import"))
gv = (GV*)&sv_yes;
- else
- gv = gv_autoload(stash, name, nend - name);
+ else if (autoload)
+ gv = gv_autoload4(stash, name, nend - name, TRUE);
+ }
+ else if (autoload) {
+ CV* cv = GvCV(gv);
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ GV* stubgv;
+ GV* autogv;
+
+ if (CvANON(cv))
+ stubgv = gv;
+ else {
+ stubgv = CvGV(cv);
+ if (GvCV(stubgv) != cv) /* orphaned import */
+ stubgv = gv;
+ }
+ autogv = gv_autoload4(GvSTASH(stubgv),
+ GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+ if (autogv)
+ gv = autogv;
+ }
}
return gv;
}
GV*
-gv_autoload(stash, name, len)
+gv_autoload4(stash, name, len, method)
HV* stash;
char* name;
STRLEN len;
+I32 method;
{
static char autoload[] = "AUTOLOAD";
static STRLEN autolen = 8;
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
- if (!(gv = gv_fetchmeth(stash, autoload, autolen, 0)))
+ if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
/*
+ * Inheriting AUTOLOAD for non-methods works ... for now.
+ */
+ if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
+ warn(
+ "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
U32 namelen;
I32 create;
{
- char tmpbuf[1203];
+ char smallbuf[256];
+ char *tmpbuf;
HV *stash;
GV *tmpgv;
- if (namelen > 1200) {
- namelen = 1200;
-#ifdef VMS
- warn("Weird package name \"%s\" truncated", name);
-#else
- warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
-#endif
- }
+ 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);
+ tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
if (!tmpgv)
return 0;
if (!GvHV(tmpgv))
I32 add;
I32 sv_type;
{
+ dTHR;
register char *name = nambeg;
register GV *gv = 0;
GV**gvp;
I32 len;
register char *namend;
HV *stash = 0;
- bool global = FALSE;
+ U32 add_gvflags = 0;
char *tmpbuf;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
if (!stash) {
if (isIDFIRST(*name)) {
+ bool global = FALSE;
+
if (isUPPER(*name)) {
if (*name > 'I') {
if (*name == 'S' && (
}
else if (*name == '_' && !name[1])
global = TRUE;
+
if (global)
stash = defstash;
else if ((COP*)curcop == &compiling) {
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
return Nullgv;
warn("Had to create %s unexpectedly", nambeg);
gv_init(gv, stash, name, len, add & 2);
gv_init_sv(gv, sv_type);
+ GvFLAGS(gv) |= add_gvflags;
/* set up magic where warranted */
switch (*name) {
IO *
newIO()
{
+ dTHR;
IO *io;
GV *iogv;
gv_check(stash)
HV* stash;
{
+ dTHR;
register HE *entry;
register I32 i;
register GV *gv;
newGVgen(pack)
char *pack;
{
- (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
- return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
+ return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+ TRUE, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
Gv_AMupdate(stash)
HV* stash;
{
+ dTHR;
GV** gvp;
HV* hv;
GV* gv;
{
int filled = 0;
int i;
- char *cp;
+ const 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] ) {
+ if ( cp = 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++) {
- cv = 0;
- cp = (char *)AMG_names[i];
-
- *buf = '('; /* A cookie: "(". */
- strcpy(buf + 1, cp);
+ SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
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! */
+ /* don't fill the cache while looking up! */
+ gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+ cv = 0;
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. */
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 {
+ if (!SvPOK(GvSV(gv))
+ || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+ FALSE)))
+ {
/* 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));
}
- /* 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);
+ cv = GvCV(gv = ngv);
}
DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
int method;
int flags;
{
+ dTHR;
MAGIC *mg;
CV *cv;
CV **cvp=NULL, **ocvp=NULL;
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 */
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+ /*
+ * Just to be extra cautious. Maybe in some
+ * additional cases sv_setsv is safe, too.
+ */
SV* newref = newSVsv(ref);
SvOBJECT_on(newref);
SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
- * concatendation */
+ * concatenation */
if (method==concat_amg || method==concat_ass_amg
|| method==repeat_amg || method==repeat_ass_amg) {
return NULL; /* Delegate operation to string conversion */
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
} else {
+ SV *msg;
if (off==-1) off=method;
- sprintf(buf,
- "Operation `%s': no method found,%sargument %s%.256s%s%.256s",
+ msg = sv_2mortal(newSVpvf(
+ "Operation `%s': no method found,%sargument %s%s%s%s",
AMG_names[method + assignshift],
(flags & AMGf_unary ? " " : "\n\tleft "),
SvAMAGIC(left)?
: ",\n\tright argument has no overloaded magic"),
SvAMAGIC(right)?
HvNAME(SvSTASH(SvRV(right))):
- "");
+ ""));
if (amtp && amtp->fallback >= AMGfallYES) {
- DEBUG_o( deb(buf) );
+ DEBUG_o( deb("%s", SvPVX(msg)) );
} else {
- croak(buf);
+ croak("%_", msg);
}
return NULL;
}
}
if (!notfound) {
DEBUG_o( deb(
- "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
AMG_names[off],
method+assignshift==off? "" :
" (initially `",
|| inc_dec_ass) RvDEEPCP(left);
}
{
+ dTHR;
dSP;
BINOP myop;
SV* res;
+ bool oldcatch = CATCH_GET;
+ CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
- myop.op_flags = OPf_KNOW|OPf_STACKED;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
if (perldb && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
EXTEND(sp, notfound + 5);
PUSHs(lr>0? right: left);
PUSHs(lr>0? left: right);
- PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
+ PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
if (notfound) {
PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
LEAVE;
SPAGAIN;
res=POPs;
PUTBACK;
+ CATCH_SET(oldcatch);
if (postpr) {
int ans;
case not_amg:
ans=!SvOK(res); break;
}
- return ans? &sv_yes: &sv_no;
+ return boolSV(ans);
} else if (method==copy_amg) {
if (!SvROK(res)) {
croak("Copy method did not return a reference");
projects / p5sagit/p5-mst-13.2.git / blobdiff