{
SV **where;
- if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
+ if (
+ !gv
+ || (
+ SvTYPE((const SV *)gv) != SVt_PVGV
+ && SvTYPE((const SV *)gv) != SVt_PVLV
+ )
+ ) {
const char *what;
if (type == SVt_PVIO) {
/*
#else
sv_setpvn(GvSV(gv), name, namelen);
#endif
- if (PERLDB_LINE || PERLDB_SAVESRC)
- hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
}
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
+ hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
return gv;
return gp;
}
+/* Assign CvGV(cv) = gv, handling weak references.
+ * See also S_anonymise_cv_maybe */
+
+void
+Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
+{
+ GV * const oldgv = CvGV(cv);
+ PERL_ARGS_ASSERT_CVGV_SET;
+
+ if (oldgv == gv)
+ return;
+
+ if (oldgv) {
+ if (CvCVGV_RC(cv)) {
+ SvREFCNT_dec(oldgv);
+ CvCVGV_RC_off(cv);
+ }
+ else {
+ sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
+ }
+ }
+
+ SvANY(cv)->xcv_gv = gv;
+ assert(!CvCVGV_RC(cv));
+
+ if (!gv)
+ return;
+
+ if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
+ else {
+ CvCVGV_RC_on(cv);
+ SvREFCNT_inc_simple_void_NN(gv);
+ }
+}
+
+/* Assign CvSTASH(cv) = st, handling weak references. */
+
+void
+Perl_cvstash_set(pTHX_ CV *cv, HV *st)
+{
+ HV *oldst = CvSTASH(cv);
+ PERL_ARGS_ASSERT_CVSTASH_SET;
+ if (oldst == st)
+ return;
+ if (oldst)
+ sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
+ SvANY(cv)->xcv_stash = st;
+ if (st)
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
+}
+
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
CV *cv;
ENTER;
if (has_constant) {
+ char *name0 = NULL;
+ if (name[len])
+ /* newCONSTSUB doesn't take a len arg, so make sure we
+ * give it a \0-terminated string */
+ name0 = savepvn(name,len);
+
/* newCONSTSUB takes ownership of the reference from us. */
- cv = newCONSTSUB(stash, name, has_constant);
+ cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+ assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
+ if (name0)
+ Safefree(name0);
/* 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. */
} else {
(void) start_subparse(0,0); /* Create empty CV in compcv. */
cv = PL_compcv;
+ GvCV(gv) = cv;
}
- GvCV(gv) = cv;
LEAVE;
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV(cv) = gv;
+ CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH(cv) = PL_curstash;
+ CvSTASH_set(cv, PL_curstash);
if (proto) {
sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
- CvSTASH(cv) = stash;
+ CvSTASH_set(cv, stash);
SvPV_set(cv, (char *)name); /* cast to lose constness warning */
SvCUR_set(cv, len);
return gv;
Safefree(tmpbuf);
if (!tmpgv)
return NULL;
- if (!GvHV(tmpgv))
- GvHV(tmpgv) = newHV();
stash = GvHV(tmpgv);
- if (!HvNAME_get(stash))
- hv_name_set(stash, name, namelen, 0);
+ assert(stash);
+ assert(HvNAME_get(stash));
return stash;
}
return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
}
+STATIC void
+S_gv_magicalize_isa(pTHX_ GV *gv)
+{
+ AV* av;
+
+ PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
+
+ av = GvAVn(gv);
+ GvMULTI_on(gv);
+ sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
+ NULL, 0);
+}
+
+STATIC void
+S_gv_magicalize_overload(pTHX_ GV *gv)
+{
+ HV* hv;
+
+ PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
+
+ hv = GvHVn(gv);
+ GvMULTI_on(gv);
+ hv_magic(hv, NULL, PERL_MAGIC_overload);
+}
+
GV *
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype sv_type)
len = name_cursor - name;
if (len > 0) {
- char smallbuf[128];
- char *tmpbuf;
-
- if (len + 2 <= (I32)sizeof (smallbuf))
- tmpbuf = smallbuf;
- else
+ const char *key;
+ if (*name_cursor == ':') {
+ key = name;
+ len += 2;
+ } else {
+ char *tmpbuf;
Newx(tmpbuf, len+2, char);
- Copy(name, tmpbuf, len, char);
- tmpbuf[len++] = ':';
- tmpbuf[len++] = ':';
- gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
+ Copy(name, tmpbuf, len, char);
+ tmpbuf[len++] = ':';
+ tmpbuf[len++] = ':';
+ key = tmpbuf;
+ }
+ gvp = (GV**)hv_fetch(stash, key, len, add);
gv = gvp ? *gvp : NULL;
if (gv && gv != (const GV *)&PL_sv_undef) {
if (SvTYPE(gv) != SVt_PVGV)
- gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
+ gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
else
GvMULTI_on(gv);
}
- if (tmpbuf != smallbuf)
- Safefree(tmpbuf);
+ if (key != name)
+ Safefree((char *)key);
if (!gv || gv == (const GV *)&PL_sv_undef)
return NULL;
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
+ else if (len == 3 && sv_type == SVt_PVAV
+ && strnEQ(name, "ISA", 3)
+ && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
+ gv_magicalize_isa(gv);
}
return gv;
} else if (no_init) {
GvMULTI_on(gv) ;
/* set up magic where warranted */
- if (len > 1) {
+ if (stash != PL_defstash) { /* not the main stash */
+ /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
+ and VERSION. All the others apply only to the main stash. */
+ if (len > 1) {
+ const char * const name2 = name + 1;
+ switch (*name) {
+ case 'E':
+ if (strnEQ(name2, "XPORT", 5))
+ GvMULTI_on(gv);
+ break;
+ case 'I':
+ if (strEQ(name2, "SA"))
+ gv_magicalize_isa(gv);
+ break;
+ case 'O':
+ if (strEQ(name2, "VERLOAD"))
+ gv_magicalize_overload(gv);
+ break;
+ case 'V':
+ if (strEQ(name2, "ERSION"))
+ GvMULTI_on(gv);
+ break;
+ }
+ }
+ }
+ else if (len > 1) {
#ifndef EBCDIC
if (*name > 'V' ) {
NOOP;
break;
case 'I':
if (strEQ(name2, "SA")) {
- AV* const av = GvAVn(gv);
- GvMULTI_on(gv);
- sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
- NULL, 0);
- /* NOTE: No support for tied ISA */
- if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
- && AvFILLp(av) == -1)
- {
- av_push(av, newSVpvs("NDBM_File"));
- gv_stashpvs("NDBM_File", GV_ADD);
- av_push(av, newSVpvs("DB_File"));
- gv_stashpvs("DB_File", GV_ADD);
- av_push(av, newSVpvs("GDBM_File"));
- gv_stashpvs("GDBM_File", GV_ADD);
- av_push(av, newSVpvs("SDBM_File"));
- gv_stashpvs("SDBM_File", GV_ADD);
- av_push(av, newSVpvs("ODBM_File"));
- gv_stashpvs("ODBM_File", GV_ADD);
- }
+ gv_magicalize_isa(gv);
}
break;
case 'O':
if (strEQ(name2, "VERLOAD")) {
- HV* const hv = GvHVn(gv);
- GvMULTI_on(gv);
- hv_magic(hv, NULL, PERL_MAGIC_overload);
+ gv_magicalize_overload(gv);
}
break;
case 'S':
if (strEQ(name2, "NCODING"))
goto magicalize;
break;
+ case '\007': /* $^GLOBAL_PHASE */
+ if (strEQ(name2, "LOBAL_PHASE"))
+ goto ro_magicalize;
+ break;
case '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
- goto magicalize;
+ goto magicalize;
+ break;
case '\024': /* ${^TAINT} */
if (strEQ(name2, "AINT"))
goto ro_magicalize;
SvGETMAGIC(arg);
- if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
+ if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
+ AMGf_noright | AMGf_unary))) {
if (flags & AMGf_set) {
SETs(tmpsv);
}
return FALSE;
}
+SV *
+Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
+ SV *tmpsv = NULL;
+
+ PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
+
+ while (SvAMAGIC(ref) &&
+ (tmpsv = amagic_call(ref, &PL_sv_undef, method,
+ AMGf_noright | AMGf_unary))) {
+ if (!SvROK(tmpsv))
+ Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
+ if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
+ /* Bail out if it returns us the same reference. */
+ return tmpsv;
+ }
+ ref = tmpsv;
+ }
+ return tmpsv ? tmpsv : ref;
+}
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
PERL_ARGS_ASSERT_AMAGIC_CALL;
if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
- SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
- 0, "overloading", 11, 0, 0);
+ SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
if ( !lex_mask || !SvOK(lex_mask) )
/* overloading lexically disabled */
&& (assign || (method == inc_amg) || (method == dec_amg)))
|| force_cpy)
{
- RvDEEPCP(left);
+ /* newSVsv does not behave as advertised, so we copy missing
+ * information by hand */
+ SV *tmpRef = SvRV(left);
+ SV *rv_copy;
+ if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLun(left,copy))) {
+ SvRV_set(left, rv_copy);
+ SvSETMAGIC(left);
+ SvREFCNT_dec(tmpRef);
+ }
}
{
HEK *namehek;
SV **gvp;
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
+
+ /* XXX Why and where does this leave dangling pointers during global
+ destruction? */
+ if (PL_phase == PERL_PHASE_DESTRUCT) return;
+
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
- !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+ !SvOBJECT(gv) && !SvREADONLY(gv) &&
isGV_with_GP(gv) && GvGP(gv) &&
!GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
+ if (SvMAGICAL(gv)) {
+ MAGIC *mg;
+ /* only backref magic is allowed */
+ if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
+ return;
+ for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type != PERL_MAGIC_backref)
+ return;
+ }
+ }
cv = GvCV(gv);
if (!cv) {
HEK *gvnhek = GvNAME_HEK(gv);