#define PERL_IN_GV_C
#include "perl.h"
+static const char S_autoload[] = "AUTOLOAD";
+static const STRLEN S_autolen = sizeof(S_autoload)-1;
+
GV *
Perl_gv_AVadd(pTHX_ register GV *gv)
{
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
+ dVAR;
register GP *gp;
const bool doproto = SvTYPE(gv) > SVt_NULL;
- char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+ const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv)) {
SvLEN_set(gv, 0);
SvPOK_off(gv);
} else
- Safefree(SvPVX(gv));
+ Safefree(SvPVX_const(gv));
}
Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
GV* gv;
GV** gvp;
CV* cv;
+ const char *hvname;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
return 0;
}
- if (!HvNAME(stash))
+ hvname = HvNAME_get(stash);
+ if (!hvname)
Perl_croak(aTHX_
"Can't use anonymous symbol table for method lookup");
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
- name, HvNAME(stash));
+ name, hvname);
- DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
+ DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
- char* packname = HvNAME(stash);
- STRLEN packlen = strlen(packname);
+ /* FIXME - get this from the symtab magic. */
+ STRLEN packlen = strlen(hvname);
- if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
+ if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
- basestash = gv_stashpvn(packname, packlen, TRUE);
+ basestash = gv_stashpvn(hvname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
- Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
+ Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
- sv, HvNAME(stash));
+ sv, hvname);
continue;
}
gv = gv_fetchmeth(basestash, name, len,
GV *gv = gv_fetchmeth(stash, name, len, level);
if (!gv) {
- char autoload[] = "AUTOLOAD";
- STRLEN autolen = sizeof(autoload)-1;
CV *cv;
GV **gvp;
if (!stash)
return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
- if (len == autolen && strnEQ(name, autoload, autolen))
+ if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
return Nullgv;
- if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+ if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
/* __PACKAGE__::SUPER stash should be autovivified */
- stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
+ stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
- origname, HvNAME(stash), name) );
+ origname, HvNAME_get(stash), name) );
}
else {
/* don't autovifify if ->NoSuchStash::method */
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
- char autoload[] = "AUTOLOAD";
- STRLEN autolen = sizeof(autoload)-1;
+ dVAR;
GV* gv;
CV* cv;
HV* varstash;
SV* varsv;
const char *packname = "";
- if (len == autolen && strnEQ(name, autoload, autolen))
+ if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
stash = Nullhv;
}
else {
- packname = HvNAME(stash);
+ packname = HvNAME_get(stash);
}
}
- if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+ if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
- vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
+ vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
ENTER;
if (!isGV(vargv))
- gv_init(vargv, varstash, autoload, autolen, FALSE);
+ gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
STATIC void
S_require_errno(pTHX_ GV *gv)
{
+ dVAR;
HV* stash = gv_stashpvn("Errno",5,FALSE);
if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
if (!GvHV(tmpgv))
GvHV(tmpgv) = newHV();
stash = GvHV(tmpgv);
- if (!HvNAME(stash))
- HvNAME(stash) = savepv(name);
+ if (!HvNAME_get(stash))
+ Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
return stash;
}
HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
{
- register char *ptr;
STRLEN len;
- ptr = SvPV(sv,len);
+ const char *ptr = SvPV(sv,len);
return gv_stashpvn(ptr, len, create);
}
GV *
Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
- STRLEN len = strlen (nambeg);
- return gv_fetchpvn_flags(nambeg, len, add, sv_type);
+ return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
}
GV *
if (!(stash = GvHV(gv)))
stash = GvHV(gv) = newHV();
- if (!HvNAME(stash))
- HvNAME(stash) = savepvn(nambeg, namend - nambeg);
+ if (!HvNAME_get(stash))
+ Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
}
if (*namend == ':')
if (strEQ(name2, "ERSION"))
GvMULTI_on(gv);
break;
+ case '\003': /* $^CHILD_ERROR_NATIVE */
+ if (strEQ(name2, "HILD_ERROR_NATIVE"))
+ goto magicalize;
+ break;
case '\005': /* $^ENCODING */
if (strEQ(name2, "NCODING"))
goto magicalize;
}
sv_setpv(sv, prefix ? prefix : "");
- name = HvNAME(hv);
+ name = HvNAME_get(hv);
if (!name)
name = "__ANON__";
IO *
Perl_newIO(pTHX)
{
- IO *io;
GV *iogv;
+ IO * const io = (IO*)NEWSV(0,0);
- io = (IO*)NEWSV(0,0);
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
Perl_gv_check(pTHX_ HV *stash)
{
register I32 i;
- register GV *gv;
- HV *hv;
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+ register GV *gv;
+ HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
{
#endif
Perl_warner(aTHX_ packWARN(WARN_ONCE),
"Name \"%s::%s\" used only once: possible typo",
- HvNAME(stash), GvNAME(gv));
+ HvNAME_get(stash), GvNAME(gv));
}
}
}
if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
- if (gp->gp_hv) {
- if (PL_stashcache && HvNAME(gp->gp_hv))
- hv_delete(PL_stashcache,
- HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
- G_DISCARD);
- SvREFCNT_dec(gp->gp_hv);
+ /* FIXME - another reference loop GV -> symtab -> GV ?
+ Somehow gp->gp_hv can end up pointing at freed garbage. */
+ if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
+ /* FIXME strlen HvNAME */
+ const char *hvname = HvNAME_get(gp->gp_hv);
+ if (PL_stashcache && hvname)
+ hv_delete(PL_stashcache, hvname, strlen(hvname), G_DISCARD);
+ SvREFCNT_dec(gp->gp_hv);
}
if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
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)) );
+ DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
Zero(&amt,1,AMT);
amt.was_ok_am = PL_amagic_generation;
const STRLEN l = strlen(cooky);
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
- cp, HvNAME(stash)) );
+ cp, HvNAME_get(stash)) );
/* don't fill the cache while looking up!
Creation of inheritance stubs in intermediate packages may
conflict with the logic of runtime method substitution.
gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
cv = 0;
if (gv && (cv = GvCV(gv))) {
+ const char *hvname;
if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
- && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+ && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
"' for overloaded `%s' in package `%.256s'\n",
- GvSV(gv), cp, HvNAME(stash)) );
+ GvSV(gv), cp, hvname) );
if (!SvPOK(GvSV(gv))
- || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+ || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
FALSE)))
{
/* Can be an import stub (created by `can'). */
SV *gvsv = GvSV(gv);
- const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
+ const char *name = SvPOK(gvsv) ? SvPVX_const(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));
+ name, cp, hvname);
}
cv = GvCV(gv = ngv);
}
DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
- cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
+ cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
GvNAME(CvGV(cv))) );
filled = 1;
if (i < DESTROY_amg)
{
MAGIC *mg;
AMT *amtp;
- CV *ret;
- if (!stash || !HvNAME(stash))
+ if (!stash || !HvNAME_get(stash))
return Nullcv;
mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
if (!mg) {
|| amtp->was_ok_sub != PL_sub_generation )
goto do_update;
if (AMT_AMAGIC(amtp)) {
- ret = amtp->table[id];
+ CV * const ret = amtp->table[id];
if (ret && isGV(ret)) { /* Autoloading stab */
/* Passing it through may have resulted in a warning
"Inherited AUTOLOAD for a non-method deprecated", since
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
+ dVAR;
MAGIC *mg;
CV *cv=NULL;
CV **cvp=NULL, **ocvp=NULL;
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 not_amg:
+ (void)((cv = cvp[off=bool__amg])
+ || (cv = cvp[off=numer_amg])
+ || (cv = cvp[off=string_amg]));
+ postpr = 1;
+ break;
case copy_amg:
{
/*
"in overloaded package ":
"has no overloaded magic",
SvAMAGIC(left)?
- HvNAME(SvSTASH(SvRV(left))):
+ HvNAME_get(SvSTASH(SvRV(left))):
"",
SvAMAGIC(right)?
",\n\tright argument in overloaded package ":
? ""
: ",\n\tright argument has no overloaded magic"),
SvAMAGIC(right)?
- HvNAME(SvSTASH(SvRV(right))):
+ HvNAME_get(SvSTASH(SvRV(right))):
""));
if (amtp && amtp->fallback >= AMGfallYES) {
- DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
+ DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, msg);
}
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
flags & AMGf_unary? " for argument" : "",
- stash ? HvNAME(stash) : "null",
+ stash ? HvNAME_get(stash) : "null",
fl? ",\n\tassignment variant used": "") );
}
#endif
dSP;
BINOP myop;
SV* res;
- bool oldcatch = CATCH_GET;
+ const bool oldcatch = CATCH_GET;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
CATCH_SET(oldcatch);
if (postpr) {
- int ans=0;
+ int ans;
switch (method) {
case le_amg:
case sle_amg:
SvSetSV(left,res); return left;
case not_amg:
ans=!SvTRUE(res); break;
+ default:
+ ans=0; break;
}
return boolSV(ans);
} else if (method==copy_amg) {
}
return FALSE;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff