#include "EXTERN.h"
#include "perl.h"
-extern char rcsid[];
+EXT char rcsid[];
GV *
gv_AVadd(gv)
gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
sv_setpv(GvSV(gv), name);
if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
if (perldb)
hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
return gv;
{
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);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
}
static void
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)) { /* Not undefed. */
+ if (!GvCVGEN(topgv) || /* not an inheritance cache */
+ GvCVGEN(topgv) >= sub_generation) /* valid inh. 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);
+ 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;
- sprintf(tmpbuf,"%.*s::",1200,name);
+
+ 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);
}
bool global = FALSE;
char *tmpbuf;
+ if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
+ name++;
+
for (namend = name; *namend; namend++) {
if ((*namend == '\'' && namend[1]) ||
(*namend == ':' && namend[1] == ':'))
{
if (!stash)
stash = defstash;
- if (!SvREFCNT(stash)) /* symbol table under destruction */
+ if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
else if (!add)
return Nullgv;
else
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;
sv_type != SVt_PVCV &&
sv_type != SVt_PVGV &&
sv_type != SVt_PVFM &&
- sv_type != SVt_PVIO)
+ 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 ||
- !(GvFLAGS(*gvp) & GVf_IMPORTED))
+ *gvp == (GV*)&sv_undef ||
+ SvTYPE(*gvp) != SVt_PVGV)
+ {
stash = 0;
- else if (sv_type == SVt_PVAV && !GvAV(*gvp) ||
- sv_type == SVt_PVHV && !GvHV(*gvp) ||
- sv_type == SVt_PV &&
- (!GvSV(*gvp) ||
- (!SvTYPE(GvSV(*gvp)) &&
- SvREFCNT(GvSV(*gvp)) == 1) ))
+ }
+ 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 exported",
+ warn("Variable \"%c%s\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
name);
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
gv_init_sv(gv, sv_type);
}
return gv;
case 'a':
case 'b':
if (len == 1)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
break;
case 'E':
if (strnEQ(name, "EXPORT", 6))
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
break;
case 'I':
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
{
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 'O':
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
}
break;
case 'S':
if (strEQ(name, "SIG")) {
HV *hv;
+ I32 i;
siggv = gv;
- SvMULTI_on(siggv);
+ 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);
case '|':
case '\001':
case '\004':
+ case '\005':
case '\006':
case '\010':
+ case '\017':
case '\t':
case '\020':
case '\024':
}
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_PVIO);
+ 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;
- if (SvMULTI(gv))
+ 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 && SvMULTI(filegv)) /* Filename began with slash */
+ 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));
}
}
gp_free(gv)
GV* gv;
{
- IO *io;
- CV *cv;
GP* gp;
+ CV* cv;
if (!gv || !(gp = GvGP(gv)))
return;
SvREFCNT_dec(gp->gp_sv);
SvREFCNT_dec(gp->gp_av);
SvREFCNT_dec(gp->gp_hv);
- if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
- do_close(gv,FALSE);
- SvREFCNT_dec(io);
- }
+ SvREFCNT_dec(gp->gp_io);
if ((cv = gp->gp_cv) && !GvCVGEN(gv))
SvREFCNT_dec(cv);
SvREFCNT_dec(gp->gp_form);
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;
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %.200s during blessing\n",
+ die("Method for operation %s not found in package %.256s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
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);
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
} else {
- char tmpstr[512];
if (off==-1) off=method;
- sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%.200s,\n\tright argument %s%.200s",
- ((char**)AMG_names)[off],
+ sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
+ ((char**)AMG_names)[method + assignshift],
SvAMAGIC(left)?
"in overloaded package ":
"has no overloaded magic",
HvNAME(SvSTASH(SvRV(right))):
"");
if (amtp && amtp->fallback >= AMGfallYES) {
- DEBUG_o( deb(tmpstr) );
+ DEBUG_o( deb(buf) );
} else {
- die(tmpstr);
+ die(buf);
}
return NULL;
}
}
}
if (!notfound) {
- DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.200s%s\n",
+ DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
((char**)AMG_names)[off],
method+assignshift==off? "" :
" (initially `",
* to dublicate the contents, probably calling user-supplied
* version of copy operator
*/
- if ((method+assignshift==off
+ if ((method + assignshift==off
&& (assign || method==inc_amg || method==dec_amg))
|| inc_dec_ass) RvDEEPCP(left);
}
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (perldb && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
PUSHs(lr>0? left: right);
PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) );
+ PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
if (op = pp_entersub())
- run();
+ runops();
LEAVE;
SPAGAIN;
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) {
projects / p5sagit/p5-mst-13.2.git / blobdiff