* if it walks like a dirhandle, then let's assume that
* this is a dirhandle.
*/
- const char *fh = PL_op->op_type == OP_READDIR ||
+ const char * const fh =
+ PL_op->op_type == OP_READDIR ||
PL_op->op_type == OP_TELLDIR ||
PL_op->op_type == OP_SEEKDIR ||
PL_op->op_type == OP_REWINDDIR ||
return SvROK(gv) ? SvRV(gv) : NULL;
}
+GP *
+Perl_newGP(pTHX_ GV *const gv)
+{
+ GP *gp;
+ const char *const file = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
+ STRLEN len = strlen(file);
+ U32 hash;
+
+ PERL_HASH(hash, file, len);
+
+ Newxz(gp, 1, GP);
+
+#ifndef PERL_DONT_CREATE_GVSV
+ gp->gv_sv = newSV(0);
+#endif
+
+ gp->gp_line = CopLINE(PL_curcop);
+ /* XXX Ideally this cast would be replaced with a change to const char*
+ in the struct. */
+ gp->gp_file_hek = share_hek(file, len, hash);
+ gp->gp_egv = gv;
+ gp->gp_refcnt = 1;
+
+ return gp;
+}
+
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;
+ const U32 old_type = SvTYPE(gv);
+ const bool doproto = old_type > SVt_NULL;
const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
SvROK_off(gv);
}
- sv_upgrade((SV*)gv, SVt_PVGV);
+
+ if (old_type < SVt_PVGV) {
+ if (old_type >= SVt_PV)
+ SvCUR_set(gv, 0);
+ sv_upgrade((SV*)gv, SVt_PVGV);
+ }
if (SvLEN(gv)) {
if (proto) {
SvPV_set(gv, NULL);
} else
Safefree(SvPVX_mutable(gv));
}
- Newxz(gp, 1, GP);
SvSCREAM_on(gv);
- GvGP(gv) = gp_ref(gp);
-#ifdef PERL_DONT_CREATE_GVSV
- GvSV(gv) = NULL;
-#else
- GvSV(gv) = newSV(0);
-#endif
- GvLINE(gv) = CopLINE(PL_curcop);
- /* XXX Ideally this cast would be replaced with a change to const char*
- in the struct. */
- GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
- GvCVGEN(gv) = 0;
- GvEGV(gv) = gv;
+
+ GvGP(gv) = Perl_newGP(aTHX_ gv);
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
- GvNAME(gv) = savepvn(name, len);
- GvNAMELEN(gv) = len;
+ gv_name_set(gv, name, len, GV_ADD);
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
- GvAV(gv) = (AV*)SvREFCNT_inc(av);
+ GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
}
}
}
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
- sv, hvname);
+ (void*)sv, hvname);
continue;
}
gv = gv_fetchmeth(basestash, name, len,
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
- SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
+ SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
GV* vargv;
SV* varsv;
const char *packname = "";
- STRLEN packname_len;
+ STRLEN packname_len = 0;
if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
return NULL;
char smallbuf[128];
char *tmpbuf;
- if (len + 3 < sizeof (smallbuf))
+ if (len + 3 < (I32)sizeof (smallbuf))
tmpbuf = smallbuf;
else
Newx(tmpbuf, len+3, char);
*gvp == (GV*)&PL_sv_undef ||
SvTYPE(*gvp) != SVt_PVGV)
{
- stash = 0;
+ stash = NULL;
}
else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
name);
if (GvCVu(*gvp))
Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
- stash = 0;
+ stash = NULL;
}
}
}
if (len > 1) {
#ifndef EBCDIC
if (*name > 'V' ) {
- /*EMPTY*/;
+ NOOP;
/* Nothing else to do.
The compiler will probably turn the switch statement into a
branch table. Make sure we avoid even that small overhead for
goto ro_magicalize;
if (strEQ(name2, "TF8LOCALE"))
goto ro_magicalize;
+ if (strEQ(name2, "TF8CACHE"))
+ goto magicalize;
break;
case '\027': /* $^WARNING_BITS */
if (strEQ(name2, "ARNING_BITS"))
sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
goto magicalize;
+ case '\010': /* $^H */
+ {
+ HV *const hv = GvHVn(gv);
+ hv_magic(hv, NULL, PERL_MAGIC_hints);
+ }
+ goto magicalize;
+
case '+':
{
AV* const av = GvAVn(gv);
case '\004': /* $^D */
case '\005': /* $^E */
case '\006': /* $^F */
- case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\016': /* $^N */
case '\017': /* $^O */
{
dVAR;
return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
- TRUE, SVt_PVGV);
+ GV_ADD, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
{
dVAR;
if (!gp)
- return (GP*)NULL;
+ return NULL;
gp->gp_refcnt++;
if (gp->gp_cv) {
if (gp->gp_cvgen) {
return;
}
- if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
- if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
+ unshare_hek(gp->gp_file_hek);
+ SvREFCNT_dec(gp->gp_sv);
+ SvREFCNT_dec(gp->gp_av);
/* 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) {
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);
- if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
+ SvREFCNT_dec(gp->gp_io);
+ SvREFCNT_dec(gp->gp_cv);
+ SvREFCNT_dec(gp->gp_form);
Safefree(gp);
GvGP(gv) = 0;
int i;
for (i = 1; i < NofAMmeth; i++) {
CV * const cv = amtp->table[i];
- if (cv != NULL) {
+ if (cv) {
SvREFCNT_dec((SV *) cv);
amtp->table[i] = NULL;
}
lim = DESTROY_amg; /* Skip overloading entries. */
#ifdef PERL_DONT_CREATE_GVSV
else if (!sv) {
- /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */
+ NOOP; /* Equivalent to !SvTRUE and !SvOK */
}
#endif
else if (SvTRUE(sv))
DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
"\" for overloaded \"%s\" in package \"%.256s\"\n",
- GvSV(gv), cp, hvname) );
+ (void*)GvSV(gv), cp, hvname) );
if (!gvsv || !SvPOK(gvsv)
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
FALSE)))
cv = (CV*)gv;
filled = 1;
}
- amt.table[i]=(CV*)SvREFCNT_inc(cv);
+ amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
}
if (filled) {
AMT_AMAGIC_on(&amt);
&& (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
- : (CV **) NULL))
+ : NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
&& (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
- : (CV **) NULL))
+ : NULL))
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
if (amtp && amtp->fallback >= AMGfallYES) {
DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
} else {
- Perl_croak(aTHX_ "%"SVf, msg);
+ Perl_croak(aTHX_ "%"SVf, (void*)msg);
}
return NULL;
}
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
+ myop.op_next = NULL;
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
PUSHSTACKi(PERLSI_OVERLOAD);
bool
Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
{
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(flags);
if (len > 1) {
return FALSE;
}
+void
+Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
+{
+ dVAR;
+ U32 hash;
+
+ assert(name);
+ PERL_UNUSED_ARG(flags);
+
+ if (len > I32_MAX)
+ Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
+
+ if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
+ unshare_hek(GvNAME_HEK(gv));
+ }
+
+ PERL_HASH(hash, name, len);
+ GvNAME_HEK(gv) = share_hek(name, len, hash);
+}
+
/*
* Local variables:
* c-indentation-style: bsd