/* gv.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (c) 1991-2003, 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.
CvGV(GvCV(gv)) = gv;
CvFILE_set_from_cop(GvCV(gv), PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
-#ifdef USE_5005THREADS
- CvOWNER(GvCV(gv)) = 0;
- if (!CvMUTEXP(GvCV(gv))) {
- New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(GvCV(gv)));
- }
-#endif /* USE_5005THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA",
- SvPVX(sv), HvNAME(stash));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+ sv, HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
register const char *nend;
const char *nsplit = 0;
GV* gv;
+ HV* ostash = stash;
+
+ if (stash && SvTYPE(stash) < SVt_PVHV)
+ stash = Nullhv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
- else
+ else {
/* don't autovifify if ->NoSuchStash::method */
stash = gv_stashpvn(origname, nsplit - origname, FALSE);
+
+ /* however, explicit calls to Pkg::SUPER::method may
+ happen, and may require autovivification to work */
+ if (!stash && (nsplit - origname) >= 7 &&
+ strnEQ(nsplit - 7, "::SUPER", 7) &&
+ gv_stashpvn(origname, nsplit - origname - 7, FALSE))
+ stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+ }
+ ostash = stash;
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
- gv = gv_autoload4(stash, name, nend - name, TRUE);
+ gv = gv_autoload4(ostash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
HV* varstash;
GV* vargv;
SV* varsv;
+ char *packname = "";
- if (!stash)
- return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
+ if (stash) {
+ if (SvTYPE(stash) < SVt_PVHV) {
+ packname = SvPV_nolen((SV*)stash);
+ stash = Nullhv;
+ }
+ else {
+ packname = HvNAME(stash);
+ }
+ }
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
- HvNAME(stash), (int)len, name);
+ packname, (int)len, name);
-#ifndef USE_5005THREADS
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
SvCUR(cv) = len;
return gv;
}
-#endif
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
-#ifdef USE_5005THREADS
- sv_lock((SV *)varstash);
-#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
-#ifdef USE_5005THREADS
- sv_lock(varsv);
-#endif
- sv_setpv(varsv, HvNAME(stash));
+ sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
char smallbuf[256];
char *tmpbuf;
- if (len + 3 < sizeof smallbuf)
+ if (len + 3 < sizeof (smallbuf))
tmpbuf = smallbuf;
else
New(601, tmpbuf, len+3, char);
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
: ""), name));
- stash = PL_nullstash;
+ stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
}
else
return Nullgv;
goto ro_magicalize;
else
break;
+ case '\025':
+ if (len > 1 && strNE(name, "\025NICODE"))
+ break;
+ goto ro_magicalize;
+
case '\027': /* $^W & $^WARNING_BITS */
- if (len > 1 && strNE(name, "\027ARNING_BITS")
- && strNE(name, "\027IDE_SYSTEM_CALLS"))
+ if (len > 1
+ && strNE(name, "\027ARNING_BITS")
+ )
break;
goto magicalize;
void
Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
- HV *hv = GvSTASH(gv);
- if (!hv) {
- (void)SvOK_off(sv);
- return;
- }
- sv_setpv(sv, prefix ? prefix : "");
- sv_catpv(sv,HvNAME(hv));
- sv_catpvn(sv,"::", 2);
- sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+ gv_fullname4(sv, gv, prefix, TRUE);
}
void
void
Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
- GV *egv = GvEGV(gv);
- if (!egv)
- egv = gv;
- gv_fullname3(sv, egv, prefix);
+ gv_efullname4(sv, gv, prefix, TRUE);
}
/* XXX compatibility with versions <= 5.003. */
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
+ /* Clear the stashcache because a new IO could overrule a
+ package name */
+ hv_clear(PL_stashcache);
iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
/* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
SvREFCNT_dec(gp->gp_sv);
SvREFCNT_dec(gp->gp_av);
+ if(gp->gp_hv && HvNAME(gp->gp_hv) && PL_stashcache)
+ hv_delete(PL_stashcache, HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), G_DISCARD);
SvREFCNT_dec(gp->gp_hv);
SvREFCNT_dec(gp->gp_io);
SvREFCNT_dec(gp->gp_cv);
GvGP(gv) = 0;
}
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#ifdef MICROPORT /* Microport 2.4 hack */
-AV *GvAVn(gv)
-register GV *gv;
-{
- if (GvGP(gv)->gp_av)
- return GvGP(gv)->gp_av;
- else
- return GvGP(gv_AVadd(gv))->gp_av;
-}
-
-HV *GvHVn(gv)
-register GV *gv;
-{
- if (GvGP(gv)->gp_hv)
- return GvGP(gv)->gp_hv;
- else
- return GvGP(gv_HVadd(gv))->gp_hv;
-}
-#endif /* Microport 2.4 hack */
-
int
Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
{
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
- return AMT_OVERLOADED(amtp);
+ return (bool)AMT_OVERLOADED(amtp);
sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
/* GvSV contains the name of the method. */
GV *ngv = Nullgv;
- DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
- SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
+ DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n",
+ GvSV(gv), 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));
+ SV *gvsv = GvSV(gv);
+ const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
+ Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'",
+ (GvCVGEN(gv) ? "Stub found while resolving"
+ : "Can't resolve"),
+ name, cp, HvNAME(stash));
}
cv = GvCV(gv = ngv);
}
break;
case '\017': /* $^O & $^OPEN */
if (len == 1
- || (len == 4 && strEQ(name, "\027PEN")))
+ || (len == 4 && strEQ(name, "\017PEN")))
{
goto yes;
}
break;
+ case '\025':
+ if (len > 1 && strEQ(name, "\025NICODE"))
+ goto yes;
case '\027': /* $^W & $^WARNING_BITS */
if (len == 1
|| (len == 12 && strEQ(name, "\027ARNING_BITS"))
- || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+ )
{
goto yes;
}