#include "EXTERN.h"
#include "perl.h"
-extern char rcsid[];
+EXT char rcsid[];
GV *
gv_AVadd(gv)
{
register GP *gp;
- sv_upgrade(gv, SVt_PVGV);
+ sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv))
Safefree(SvPVX(gv));
Newz(602,gp, 1, GP);
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 = GvCV(topgv)) {
+ if (CvXSUB(cv) || CvROOT(cv) || CvGV(cv)) { /* Not deleted, possibly autoloaded. */
+ if (GvCVGEN(topgv) >= sub_generation)
+ return topgv; /* valid cached inheritance */
+ if (!GvCVGEN(topgv)) { /* not an inheritance cache */
+ return topgv;
+ }
}
+ /* stale cached entry, just junk it */
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = cv = 0;
+ GvCVGEN(topgv) = 0;
}
- /* if cv is still set, we have to free it if we find something to cache */
+ /* Now cv = 0, and there is no cv in topgv. */
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 */
+ SvREFCNT_inc(GvCV(gv));
return gv;
}
}
}
if (!level) {
- if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
+ 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 */
+ SvREFCNT_inc(GvCV(gv));
return gv;
}
}
/* 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);
+ 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_stashpv(origname,TRUE);
+ stash = gv_stashpvn(origname, nsplit - origname, TRUE);
*nsplit = ch;
}
}
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-7];
+ char ch = packname[len];
AV *av;
- packname[len-7] = '\0';
- basestash = gv_stashpv(packname, TRUE);
- packname[len-7] = ch;
+ 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 */
if (!gv) {
CV* cv;
- if (strEQ(name,"import") || strEQ(name,"unimport"))
- gv = &sv_yes;
+ if (strEQ(name,"import"))
+ gv = (GV*)&sv_yes;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
if (gv && (cv = GvCV(gv))) { /* One more chance... */
sv_catpvn(tmpstr,"::", 2);
sv_catpvn(tmpstr, name, nend - name);
sv_setsv(GvSV(CvGV(cv)), tmpstr);
- if (tainting)
- sv_unmagic(GvSV(CvGV(cv)), 't');
+ SvTAINTED_off(GvSV(CvGV(cv)));
}
}
}
char *name;
I32 create;
{
- char tmpbuf[1234];
+ 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;
- /* 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, "::");
+
+ 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;
SV *sv;
I32 create;
{
- return gv_stashpv(SvPV(sv,na), create);
+ register char *ptr;
+ STRLEN len;
+ ptr = SvPV(sv,len);
+ return gv_stashpvn(ptr, len, create);
}
{
if (!stash)
stash = defstash;
- if (!SvREFCNT(stash)) /* symbol table under destruction */
+ if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
namend++;
name = namend;
if (!*name)
- return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
+ return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
}
}
len = namend - name;
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "DB_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 7, TRUE);
av_push(av, newSVpv(pname = "GDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "SDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "ODBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
}
}
break;
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);
}
void
-gv_fullname(sv,gv)
+gv_fullname3(sv, gv, prefix)
SV *sv;
GV *gv;
+char *prefix;
{
HV *hv = GvSTASH(gv);
-
- if (!hv)
+ if (!hv) {
+ 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)
+gv_efullname3(sv, gv, prefix)
SV *sv;
GV *gv;
+char *prefix;
{
- GV* egv = GvEGV(gv);
- HV *hv;
-
+ GV *egv = GvEGV(gv);
if (!egv)
egv = gv;
- hv = GvSTASH(egv);
- if (!hv)
- return;
+ gv_fullname3(sv, egv, prefix);
+}
- 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
+gv_fullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+}
+
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_efullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}
IO *
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
- iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVHV);
+ iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
}
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
- for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
- if (entry->hent_key[entry->hent_klen-1] == ':' &&
- (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
+ 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(*entry->hent_key)) {
- gv = (GV*)entry->hent_val;
+ else if (isALPHA(*HeKEY(entry))) {
+ gv = (GV*)HeVAL(entry);
if (GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
- warn("Identifier \"%s::%s\" used only once: possible typo",
+ warn("Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
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))
if ( (cp=((char**)(*AMG_names))[i]) ) {
svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
- if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
+ if (svp && ((sv = *svp) != &sv_undef)) {
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- die("Not a subroutine reference in %%OVERLOAD");
+ die("Not a subroutine reference in overload table");
return FALSE;
case SVt_PVCV:
cv = (CV*)sv;
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);
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (perldb && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
ans=SvIV(res)!=0; break;
case inc_amg:
case dec_amg:
- SvSetSV(left,res); return res; break;
+ SvSetSV(left,res); return left;
+ case not_amg:
+ans=!SvOK(res); break;
}
return ans? &sv_yes: &sv_no;
} else if (method==copy_amg) {