X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=c136fc5ed45fd14d7f51bc35bc127db068751702;hb=974f612f96f3c8ea5c8348144028f6dde840e2f5;hp=9e1f5337d4268e9fc47bef277ebf1231ec97563b;hpb=79072805bf63abe5b5978b5928ab00d360ea3e7f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 9e1f533..c136fc5 100644 --- a/gv.c +++ b/gv.c @@ -1,52 +1,32 @@ -/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $ +/* gv.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, 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" #include "perl.h" +extern char rcsid[]; + GV * gv_AVadd(gv) register GV *gv; { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); return gv; @@ -56,8 +36,21 @@ GV * gv_HVadd(gv) register GV *gv; { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for hash"); if (!GvHV(gv)) - GvHV(gv) = newHV(COEFFSIZE); + GvHV(gv) = newHV(); + return gv; +} + +GV * +gv_IOadd(gv) +register GV *gv; +{ + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for filehandle"); + if (!GvIOp(gv)) + GvIOp(gv) = newIO(); return gv; } @@ -68,155 +61,628 @@ char *name; char tmpbuf[1200]; GV *gv; - sprintf(tmpbuf,"'_<%s", name); - gv = gv_fetchpv(tmpbuf, TRUE); + sprintf(tmpbuf,"::_<%s", name); + gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); sv_setpv(GvSV(gv), name); + if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) + GvMULTI_on(gv); if (perldb) - (void)gv_HVadd(gv_AVadd(gv)); + hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; } +void +gv_init(gv, stash, name, len, multi) +GV *gv; +HV *stash; +char *name; +STRLEN len; +int multi; +{ + register GP *gp; + + sv_upgrade((SV*)gv, SVt_PVGV); + if (SvLEN(gv)) + 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; + GvEGV(gv) = gv; + sv_magic((SV*)gv, (SV*)gv, '*', name, len); + GvSTASH(gv) = stash; + GvNAME(gv) = savepvn(name, len); + GvNAMELEN(gv) = len; + if (multi) + GvMULTI_on(gv); +} + +static void +gv_init_sv(gv, sv_type) +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; + } +} + GV * -gv_fetchmethod(stash, name) +gv_fetchmeth(stash, name, len, level) HV* stash; char* name; +STRLEN len; +I32 level; { AV* av; + GV* topgv; GV* gv; - GV** gvp = (GV**)hv_fetch(stash,name,strlen(name),FALSE); - if (gvp && (gv = *gvp) != (GV*)&sv_undef && GvCV(gv)) - return gv; + GV** gvp; + HV* lastchance; + CV* cv; + + if (!stash) + return 0; + if (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; + 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))) { SV** svp = AvARRAY(av); I32 items = AvFILL(av) + 1; while (items--) { - char tmpbuf[512]; SV* sv = *svp++; - *tmpbuf = '_'; - SvUPGRADE(sv, SVt_PV); - strcpy(tmpbuf+1,SvPVn(sv)); - gv = gv_fetchpv(tmpbuf,FALSE); - if (!gv || !(stash = GvHV(gv))) { + HV* basestash = gv_stashsv(sv, FALSE); + if (!basestash) { if (dowarn) - warn("Can't locate package %s for @%s'ISA", - SvPV(sv), HvNAME(stash)); + warn("Can't locate package %s for @%s::ISA", + SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmethod(stash, name); - if (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_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); + } + GvCV(topgv) = GvCV(gv); /* cache the CV */ + GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; + } } } + return 0; } GV * -gv_fetchpv(name,add) -register char *name; +gv_fetchmethod(stash, name) +HV* stash; +char* name; +{ + register char *nend; + char *nsplit = 0; + GV* gv; + + for (nend = name; *nend; nend++) { + if (*nend == ':' || *nend == '\'') + 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; + } + } + 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) >= 0 && strEQ(packname+len,"::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]; + 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)); + } + } + } + } + } + + if (!gv) { + CV* cv; + + if (strEQ(name,"import") || strEQ(name,"unimport")) + 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); + if (tainting) + sv_unmagic(GvSV(CvGV(cv)), 't'); + } + } + } + return gv; +} + +HV* +gv_stashpv(name,create) +char *name; +I32 create; +{ + return gv_stashpvn(name, strlen(name), create); +} + +HV* +gv_stashpvn(name,namelen,create) +char *name; +U32 namelen; +I32 create; +{ + char tmpbuf[1203]; + 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", namelen, name); +#endif + } + Copy(name,tmpbuf,namelen,char); + tmpbuf[namelen++] = ':'; + tmpbuf[namelen++] = ':'; + tmpbuf[namelen] = '\0'; + tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV); + if (!tmpgv) + return 0; + if (!GvHV(tmpgv)) + GvHV(tmpgv) = newHV(); + stash = GvHV(tmpgv); + if (!HvNAME(stash)) + HvNAME(stash) = savepv(name); + return stash; +} + +HV* +gv_stashsv(sv,create) +SV *sv; +I32 create; +{ + register char *ptr; + STRLEN len; + ptr = SvPV(sv,len); + return gv_stashpvn(ptr, len, create); +} + + +GV * +gv_fetchpv(nambeg,add,sv_type) +char *nambeg; I32 add; +I32 sv_type; { - register GV *gv; + register char *name = nambeg; + register GV *gv = 0; GV**gvp; - register GP *gp; I32 len; register char *namend; - HV *stash; - char *sawquote = Nullch; - char *prevquote = Nullch; + HV *stash = 0; bool global = FALSE; + char *tmpbuf; - 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; + if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ + name++; + + for (namend = name; *namend; namend++) { + if ((*namend == '\'' && namend[1]) || + (*namend == ':' && namend[1] == ':')) + { + if (!stash) + stash = defstash; + if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ + return Nullgv; + + len = namend - name; + if (len > 0) { + 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) + return Nullgv; + else + gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); + + if (!(stash = GvHV(gv))) + stash = GvHV(gv) = newHV(); + + if (!HvNAME(stash)) + HvNAME(stash) = savepvn(nambeg, namend - nambeg); + } + + if (*namend == ':') + namend++; + namend++; + name = namend; + if (!*name) + return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE); } - else if (*name > 'A') { - if (*name == 'E' && strEQ(name, "ENV")) + } + len = namend - name; + if (!len) + len = 1; + + /* No stash in name, so see how we can default */ + + if (!stash) { + if (isIDFIRST(*name)) { + 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; + } + else if (*name == 'A' && ( + strEQ(name, "ARGV") || + 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) && + 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 + stash = curcop->cop_stash; } - else if (*name == 'A' && ( - strEQ(name, "ARGV") || - strEQ(name, "ARGVOUT") )) - global = TRUE; - } - for (namend = name; *namend; namend++) { - if (*namend == '\'' && namend[1]) - prevquote = sawquote, sawquote = namend; - } - if (sawquote == name && name[1]) { - stash = defstash; - sawquote = Nullch; - name++; + else + stash = defstash; } - else if (!isALPHA(*name) || global) - stash = defstash; - else if ((COP*)curcop == &compiling) - stash = curstash; - else - stash = curcop->cop_stash; - if (sawquote) { - char tmpbuf[256]; - char *s, *d; - - *sawquote = '\0'; - /*SUPPRESS 560*/ - if (s = prevquote) { - strncpy(tmpbuf,name,s-name+1); - d = tmpbuf+(s-name+1); - *d++ = '_'; - strcpy(d,s+1); - } - else { - *tmpbuf = '_'; - strcpy(tmpbuf+1,name); + + /* 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 */ } - gv = gv_fetchpv(tmpbuf,TRUE); - if (!(stash = GvHV(gv))) - stash = GvHV(gv) = newHV(0); - if (!HvNAME(stash)) - HvNAME(stash) = savestr(name); - name = sawquote+1; - *sawquote = '\''; + else + return Nullgv; } - len = namend - name; + + if (!SvREFCNT(stash)) /* symbol table under destruction */ + return Nullgv; + gvp = (GV**)hv_fetch(stash,name,len,add); if (!gvp || *gvp == (GV*)&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 { - sv_upgrade(gv, SVt_PVGV); - if (SvLEN(gv)) - Safefree(SvPV(gv)); - Newz(602,gp, 1, GP); - GvGP(gv) = gp; - GvREFCNT(gv) = 1; - GvSV(gv) = NEWSV(72,0); - GvLINE(gv) = curcop->cop_line; - GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', name, len); - GvSTASH(gv) = stash; - GvNAME(gv) = nsavestr(name, len); - GvNAMELEN(gv) = len; - if (isDIGIT(*name) && *name != '0') - sv_magic(GvSV(gv), (SV*)gv, 0, name, len); - if (add & 2) - SvMULTI_on(gv); - return gv; + + /* Adding a new symbol */ + + if (add & 4) + warn("Had to create %s unexpectedly", nambeg); + gv_init(gv, stash, name, len, add & 2); + gv_init_sv(gv, sv_type); + + /* set up magic where warranted */ + switch (*name) { + case 'A': + if (strEQ(name, "ARGV")) { + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } + break; + + case 'a': + case 'b': + if (len == 1) + GvMULTI_on(gv); + break; + case 'E': + if (strnEQ(name, "EXPORT", 6)) + GvMULTI_on(gv); + break; + case 'I': + if (strEQ(name, "ISA")) { + 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) + { + char *pname; + av_push(av, newSVpv(pname = "NDBM_File",0)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpv(pname = "DB_File",0)); + gv_stashpvn(pname, 7, TRUE); + av_push(av, newSVpv(pname = "GDBM_File",0)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpv(pname = "SDBM_File",0)); + gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpv(pname = "ODBM_File",0)); + gv_stashpvn(pname, 9, TRUE); + } + } + break; +#ifdef OVERLOAD + case 'O': + if (strEQ(name, "OVERLOAD")) { + HV* hv = GvHVn(gv); + GvMULTI_on(gv); + sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); + } + break; +#endif /* OVERLOAD */ + case 'S': + 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++) { + SV ** init; + init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1); + if(init) + sv_setsv(*init,&sv_undef); + psig_ptr[i] = 0; + 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; + goto ro_magicalize; + + case '`': + if (len > 1) + break; + leftgv = gv; + sawampersand = TRUE; + goto ro_magicalize; + + case '\'': + if (len > 1) + break; + rightgv = gv; + sawampersand = TRUE; + goto ro_magicalize; + + case ':': + if (len > 1) + break; + sv_setpv(GvSV(gv),chopset); + goto magicalize; + + case '#': + case '*': + if (dowarn && len == 1 && sv_type == SVt_PV) + warn("Use of $%s is deprecated", name); + /* FALL THROUGH */ + case '[': + case '!': + case '?': + case '^': + case '~': + case '=': + case '-': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '\001': + case '\004': + case '\005': + case '\006': + case '\010': + case '\017': + case '\t': + case '\020': + case '\024': + case '\027': + if (len > 1) + break; + goto magicalize; + + case '+': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + 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': + if (len > 1) + break; + sv_setpv(GvSV(gv),"\f"); + formfeed = GvSV(gv); + break; + case ';': + if (len > 1) + break; + sv_setpv(GvSV(gv),"\034"); + break; + case ']': + if (len == 1) { + SV *sv; + sv = GvSV(gv); + sv_upgrade(sv, SVt_PVNV); + sv_setpv(sv, patchlevel); + } + break; } + return gv; } void @@ -230,7 +696,7 @@ GV *gv; return; sv_setpv(sv, sv == (SV*)gv ? "*" : ""); sv_catpv(sv,HvNAME(hv)); - sv_catpvn(sv,"'", 1); + sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } @@ -240,13 +706,17 @@ SV *sv; 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,"'", 1); + sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv)); } @@ -254,37 +724,59 @@ IO * newIO() { IO *io; + GV *iogv; - Newz(603,io,1,IO); - io->page_len = 60; + io = (IO*)NEWSV(0,0); + sv_upgrade((SV *)io,SVt_PVIO); + SvREFCNT(io) = 1; + SvOBJECT_on(io); + iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); + SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } void -gv_check(min,max) -I32 min; -register I32 max; +gv_check(stash) +HV* stash; { register HE *entry; register I32 i; register GV *gv; + HV *hv; + GV *filegv; - for (i = min; i <= max; i++) { - for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) { - gv = (GV*)entry->hent_val; - if (SvMULTI(gv)) - continue; - curcop->cop_line = GvLINE(gv); - warn("Possible typo: \"%s\"", GvNAME(gv)); + if (!HvARRAY(stash)) + return; + 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 != defstash) + gv_check(hv); /* nested package */ + } + else if (isALPHA(*HeKEY(entry))) { + gv = (GV*)HeVAL(entry); + if (GvMULTI(gv)) + continue; + curcop->cop_line = GvLINE(gv); + filegv = GvFILEGV(gv); + curcop->cop_filegv = filegv; + if (filegv && GvMULTI(filegv)) /* Filename began with slash */ + continue; + warn("Name \"%s::%s\" used only once: possible typo", + HvNAME(stash), GvNAME(gv)); + } } } } GV * -newGVgen() +newGVgen(pack) +char *pack; { - (void)sprintf(tokenbuf,"_GEN_%d",gensym++); - return gv_fetchpv(tokenbuf,TRUE); + (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++); + return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ @@ -302,9 +794,8 @@ void gp_free(gv) GV* gv; { - IO *io; - CV *cv; GP* gp; + CV* cv; if (!gv || !(gp = GvGP(gv))) return; @@ -312,20 +803,20 @@ GV* gv; 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; - - sv_free(gp->gp_sv); - sv_free(gp->gp_av); - sv_free(gp->gp_hv); - if (io = gp->gp_io) { - do_close(gv,FALSE); - Safefree(io->top_name); - Safefree(io->fmt_name); - Safefree(io); } - if (cv = gp->gp_cv) - sv_free(cv); + + SvREFCNT_dec(gp->gp_sv); + 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_form); + Safefree(gp); GvGP(gv) = 0; } @@ -354,35 +845,392 @@ register GV *gv; } #endif /* Microport 2.4 hack */ -GV * -fetch_gv(op,num) -OP *op; -I32 num; +#ifdef OVERLOAD +/* Updates and caches the CV's */ + +bool +Gv_AMupdate(stash) +HV* stash; { - if (op->op_private < num) - return 0; - if (op->op_flags & OPf_STACKED) - return gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE); - else - return cGVOP->op_gv; + GV** gvp; + HV* hv; + GV* gv; + CV* cv; + MAGIC* mg=mg_find((SV*)stash,'c'); + 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;itable[i]) { + SvREFCNT_dec(amtp->table[i]); + } + } + } + sv_unmagic((SV*)stash, 'c'); + + DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); + + 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 (SvTRUE(sv)) amt.fallback=AMGfallYES; + else if (SvOK(sv)) amt.fallback=AMGfallNEVER; + } + + for (i=1;img_ptr)->table)) + && ((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(SvPVnx(*(stack_sp--)),TRUE); - else - gv = cGVOP->op_gv; + /* look for substituted methods */ + 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; + } + 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; + } + 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=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=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; + 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 = ((amtp=(AMT*)mg->mg_ptr)->table)) + && (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 + * concatendation */ + 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 die */ + 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], + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + HvNAME(SvSTASH(SvRV(left))): + "", + SvAMAGIC(right)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(right)? + HvNAME(SvSTASH(SvRV(right))): + ""); + if (amtp && amtp->fallback >= AMGfallYES) { + DEBUG_o( deb(buf) ); + } else { + die(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], + 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 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; + BINOP myop; + SV* res; - if (!gv) - return 0; + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_KNOW|OPf_STACKED; + + ENTER; + SAVESPTR(op); + op = (OP *) &myop; + if (perldb && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; + PUTBACK; + pp_pushmark(); + + EXTEND(sp, notfound + 5); + PUSHs(lr>0? right: left); + 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*)cv); + PUTBACK; - return GvIOn(gv); + if (op = pp_entersub()) + runops(); + LEAVE; + SPAGAIN; + + res=POPs; + PUTBACK; + + if (notfound) { + /* sv_2mortal(res); */ + return NULL; + } + + 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 res; break; + case not_amg: +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"); + } + return SvREFCNT_inc(SvRV(res)); + } else { + return res; + } + } } +#endif /* OVERLOAD */