}
}
+/* 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)
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH(cv) = PL_curstash;
- if (PL_curstash)
- Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
+ 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;
- if (stash)
- Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv));
+ CvSTASH_set(cv, stash);
SvPV_set(cv, (char *)name); /* cast to lose constness warning */
SvCUR_set(cv, len);
return gv;
}
STATIC void
-S_gv_magicalize_isa(pTHX_ GV *gv, const char *nambeg, I32 add)
+S_gv_magicalize_isa(pTHX_ GV *gv)
{
AV* av;
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);
- }
}
STATIC void
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) {
break;
case 'I':
if (strEQ(name2, "SA"))
- gv_magicalize_isa(gv, nambeg, add);
+ gv_magicalize_isa(gv);
break;
case 'O':
if (strEQ(name2, "VERLOAD"))
break;
case 'I':
if (strEQ(name2, "SA")) {
- gv_magicalize_isa(gv, nambeg, add);
+ gv_magicalize_isa(gv);
}
break;
case 'O':
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);
+ }
}
{
/* XXX Why and where does this leave dangling pointers during global
destruction? */
- if (PL_dirty) return;
+ if (PL_phase == PERL_PHASE_DESTRUCT) return;
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
!SvOBJECT(gv) && !SvREADONLY(gv) &&