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 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;
+ const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
assert (!(proto && has_constant));
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
sv_reftype(has_constant, 0));
+ default: NOOP;
}
SvRV_set(gv, NULL);
SvROK_off(gv);
} 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;
+ SvIOK_off(gv);
+ isGV_with_GP_on(gv);
+
+ GvGP(gv) = Perl_newGP(aTHX_ gv);
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
- SvIOK_off(gv);
ENTER;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+ /* If this reference was a copy of another, then the subroutine
+ must have been "imported", by a Perl space assignment to a GV
+ from a reference to CV. */
+ if (exported_constant)
+ GvIMPORTED_CV_on(gv);
} else {
/* XXX unsafe for threads if eval_owner isn't held */
(void) start_subparse(0,0); /* Create empty CV in compcv. */
GV** gvp;
CV* cv;
const char *hvname;
+ HV* lastchance = NULL;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
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,
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
- HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
+ lastchance = gv_stashpvs("UNIVERSAL", FALSE);
if (lastchance) {
if ((gv = gv_fetchmeth(lastchance, name, len,
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;
sv_setpvn(varsv, packname, packname_len);
sv_catpvs(varsv, "::");
sv_catpvn(varsv, name, len);
- SvTAINTED_off(varsv);
return gv;
}
char smallbuf[128];
char *tmpbuf;
- if (len + 3 < sizeof (smallbuf))
+ if (len + 3 < (I32)sizeof (smallbuf))
tmpbuf = smallbuf;
else
Newx(tmpbuf, len+3, char);
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
: ""), name);
+ GV *gv;
if (USE_UTF8_IN_NAMES)
SvUTF8_on(err);
qerror(err);
- stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
+ gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
+ if(!gv) {
+ /* symbol table under destruction */
+ return NULL;
+ }
+ stash = GvHV(gv);
}
else
return 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
if (strEQ(name2, "RGV")) {
IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
}
+ else if (strEQ(name2, "RGVOUT")) {
+ GvMULTI_on(gv);
+ }
break;
case 'E':
if (strnEQ(name2, "XPORT", 5))
goto magicalize;
case '+':
+ GvMULTI_on(gv);
{
AV* const av = GvAVn(gv);
+ HV* const hv = GvHVn(gv);
sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
SvREADONLY_on(av);
+ hv_magic(hv, NULL, PERL_MAGIC_regdata_names);
+ SvREADONLY_on(hv);
/* FALL THROUGH */
}
case '\023': /* $^S */
}
void
-Perl_gv_check(pTHX_ HV *stash)
+Perl_gv_check(pTHX_ const HV *stash)
{
dVAR;
register I32 i;
return;
}
+ if (gp->gp_file_hek)
+ unshare_hek(gp->gp_file_hek);
SvREFCNT_dec(gp->gp_sv);
SvREFCNT_dec(gp->gp_av);
/* FIXME - another reference loop GV -> symtab -> GV ?
{
dVAR;
MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
- AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- if (mg && amtp->was_ok_am == PL_amagic_generation
- && amtp->was_ok_sub == PL_sub_generation)
- return (bool)AMT_OVERLOADED(amtp);
- sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
+ if (mg) {
+ const AMT * const amtp = (AMT*)mg->mg_ptr;
+ if (amtp->was_ok_am == PL_amagic_generation
+ && amtp->was_ok_sub == PL_sub_generation) {
+ 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_get(stash)) );
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)))
Gv_AMupdate(stash);
mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
}
+ assert(mg);
amtp = (AMT*)mg->mg_ptr;
if ( amtp->was_ok_am != PL_amagic_generation
|| amtp->was_ok_sub != PL_sub_generation )
*/
SV* const newref = newSVsv(tmpRef);
SvOBJECT_on(newref);
+ /* As a bit of a source compatibility hack, SvAMAGIC() and
+ friends dereference an RV, to behave the same was as when
+ overloading was stored on the reference, not the referant.
+ Hence we can't use SvAMAGIC_on()
+ */
+ SvFLAGS(newref) |= SVf_AMAGIC;
SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
return newref;
}
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
+ } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+ /* Skip generating the "no method found" message. */
+ return NULL;
} else {
SV *msg;
if (off==-1) off=method;
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;
}
dVAR;
U32 hash;
+ assert(name);
PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
}
PERL_HASH(hash, name, len);
- GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0;
+ GvNAME_HEK(gv) = share_hek(name, len, hash);
}
/*