{
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)
{
SvIOK_off(gv);
isGV_with_GP_on(gv);
- GvGP(gv) = Perl_newGP(aTHX_ gv);
+ GvGP_set(gv, Perl_newGP(aTHX_ gv));
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
+ 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. */
- GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+ cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+ /* In case op.c:S_process_special_blocks stole it: */
+ if (!GvCV(gv))
+ GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
+ 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. */
GvIMPORTED_CV_on(gv);
} else {
(void) start_subparse(0,0); /* Create empty CV in compcv. */
- GvCV(gv) = PL_compcv;
+ cv = PL_compcv;
+ GvCV_set(gv,cv);
}
LEAVE;
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV(GvCV(gv)) = gv;
- CvFILE_set_from_cop(GvCV(gv), PL_curcop);
- CvSTASH(GvCV(gv)) = PL_curstash;
+ CvGV_set(cv, gv);
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
if (proto) {
- sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen,
+ sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
}
}
else {
/* stale cache entry, junk it and move on */
SvREFCNT_dec(cand_cv);
- GvCV(topgv) = cand_cv = NULL;
+ GvCV_set(topgv, NULL);
+ cand_cv = NULL;
GvCVGEN(topgv) = 0;
}
}
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
- GvCV(topgv) = cand_cv;
+ GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
}
return candidate;
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
- GvCV(topgv) = cand_cv;
+ GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
}
return candidate;
/* Right now this is exclusively for the benefit of S_method_common
in pp_hot.c */
if (stash) {
+ /* If we can't find an IO::File method, it might be a call on
+ * a filehandle. If IO:File has not been loaded, try to
+ * require it first instead of croaking */
+ const char *stash_name = HvNAME_get(stash);
+ if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
+ && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
+ STR_WITH_LEN("IO/File.pm"), 0,
+ HV_FETCH_ISEXISTS, NULL, 0)
+ ) {
+ require_pv("IO/File.pm");
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
+ if (gv)
+ return gv;
+ }
Perl_croak(aTHX_
"Can't locate object method \"%s\" via package \"%.*s\"",
name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
* 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;
/* require_tie_mod() internal routine for requiring a module
- * that implements the logic of automatical ties like %! and %-
+ * that implements the logic of automatic ties like %! and %-
*
* The "gv" parameter should be the glob.
* "varpv" holds the name of the var, used for error messages.
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(key);
if (!gv || gv == (const GV *)&PL_sv_undef)
return NULL;
if (!(stash = GvHV(gv)))
+ {
stash = GvHV(gv) = newHV();
-
- if (!HvNAME_get(stash))
+ if (!HvNAME_get(stash)) {
+ hv_name_set(stash, nambeg, name_cursor-nambeg, 0);
+ /* If the containing stash has multiple effective
+ names, see that this one gets them, too. */
+ if (HvAUX(GvSTASH(gv))->xhv_name_count)
+ mro_package_moved(stash, NULL, gv, 1);
+ }
+ }
+ else if (!HvNAME_get(stash))
hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
}
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
/* diag_listed_as: Variable "%s" is not imported%s */
- Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
+ Perl_ck_warner_d(
+ aTHX_ packWARN(WARN_MISC),
+ "Variable \"%c%s\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
name);
if (GvCVu(*gvp))
- Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
+ Perl_ck_warner_d(
+ aTHX_ packWARN(WARN_MISC),
+ "\t(Did you mean &%s instead?)\n", name
+ );
stash = 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;
void
Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- const GV * const egv = GvEGV(gv);
+ const GV * const egv = GvEGVx(gv);
PERL_ARGS_ASSERT_GV_EFULLNAME4;
{
dVAR;
GP* gp;
+ int attempts = 100;
if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
return;
if (--gp->gp_refcnt > 0) {
if (gp->gp_egv == gv)
gp->gp_egv = 0;
- GvGP(gv) = 0;
+ GvGP_set(gv, NULL);
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 ?
- Somehow gp->gp_hv can end up pointing at freed garbage. */
- if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
- const char *hvname = HvNAME_get(gp->gp_hv);
+ while (1) {
+ /* Copy and null out all the glob slots, so destructors do not see
+ freed SVs. */
+ HEK * const file_hek = gp->gp_file_hek;
+ SV * const sv = gp->gp_sv;
+ AV * const av = gp->gp_av;
+ HV * const hv = gp->gp_hv;
+ IO * const io = gp->gp_io;
+ CV * const cv = gp->gp_cv;
+ CV * const form = gp->gp_form;
+
+ gp->gp_file_hek = NULL;
+ gp->gp_sv = NULL;
+ gp->gp_av = NULL;
+ gp->gp_hv = NULL;
+ gp->gp_io = NULL;
+ gp->gp_cv = NULL;
+ gp->gp_form = NULL;
+
+ if (file_hek)
+ unshare_hek(file_hek);
+
+ SvREFCNT_dec(sv);
+ SvREFCNT_dec(av);
+ /* FIXME - another reference loop GV -> symtab -> GV ?
+ Somehow gp->gp_hv can end up pointing at freed garbage. */
+ if (hv && SvTYPE(hv) == SVt_PVHV) {
+ const char *hvname = HvNAME_get(hv);
if (PL_stashcache && hvname)
- (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
+ (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
G_DISCARD);
- SvREFCNT_dec(gp->gp_hv);
+ SvREFCNT_dec(hv);
+ }
+ SvREFCNT_dec(io);
+ SvREFCNT_dec(cv);
+ SvREFCNT_dec(form);
+
+ if (!gp->gp_file_hek
+ && !gp->gp_sv
+ && !gp->gp_av
+ && !gp->gp_hv
+ && !gp->gp_io
+ && !gp->gp_cv
+ && !gp->gp_form) break;
+
+ if (--attempts == 0) {
+ Perl_die(aTHX_
+ "panic: gp_free failed to free glob pointer - "
+ "something is repeatedly re-creating entries"
+ );
+ }
}
- SvREFCNT_dec(gp->gp_io);
- SvREFCNT_dec(gp->gp_cv);
- SvREFCNT_dec(gp->gp_form);
Safefree(gp);
- GvGP(gv) = 0;
+ GvGP_set(gv, NULL);
}
int
do_update:
/* If we're looking up a destructor to invoke, we must avoid
* that Gv_AMupdate croaks, because we might be dying already */
- if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
+ if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
/* and if it didn't found a destructor, we fall back
* to a simpler method that will only look for the
* destructor instead of the whole magic */
}
+/* Implement tryAMAGICun_MG macro.
+ Do get magic, then see if the stack arg is overloaded and if so call it.
+ Flags:
+ AMGf_set return the arg using SETs rather than assigning to
+ the targ
+ AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_un(pTHX_ int method, int flags) {
+ dVAR;
+ dSP;
+ SV* tmpsv;
+ SV* const arg = TOPs;
+
+ SvGETMAGIC(arg);
+
+ if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
+ AMGf_noright | AMGf_unary))) {
+ if (flags & AMGf_set) {
+ SETs(tmpsv);
+ }
+ else {
+ dTARGET;
+ if (SvPADMY(TARG)) {
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+ }
+ PUTBACK;
+ return TRUE;
+ }
+
+ if ((flags & AMGf_numeric) && SvROK(arg))
+ *sp = sv_2num(arg);
+ return FALSE;
+}
+
+
+/* Implement tryAMAGICbin_MG macro.
+ Do get magic, then see if the two stack args are overloaded and if so
+ call it.
+ Flags:
+ AMGf_set return the arg using SETs rather than assigning to
+ the targ
+ AMGf_assign op may be called as mutator (eg +=)
+ AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_bin(pTHX_ int method, int flags) {
+ dVAR;
+ dSP;
+ SV* const left = TOPm1s;
+ SV* const right = TOPs;
+
+ SvGETMAGIC(left);
+ if (left != right)
+ SvGETMAGIC(right);
+
+ if (SvAMAGIC(left) || SvAMAGIC(right)) {
+ SV * const tmpsv = amagic_call(left, right, method,
+ ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+ if (tmpsv) {
+ if (flags & AMGf_set) {
+ (void)POPs;
+ SETs(tmpsv);
+ }
+ else {
+ dATARGET;
+ (void)POPs;
+ if (opASSIGN || SvPADMY(TARG)) {
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+ }
+ PUTBACK;
+ return TRUE;
+ }
+ }
+ if (flags & AMGf_numeric) {
+ if (SvROK(left))
+ *(sp-1) = sv_2num(left);
+ if (SvROK(right))
+ *sp = sv_2num(right);
+ }
+ 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)
{
int postpr = 0, force_cpy = 0;
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
+ int use_default_op = 0;
#ifdef DEBUGGING
int fl=0;
#endif
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 */
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
- } else if (((ocvp && oamtp->fallback > AMGfallNEVER
- && (cvp=ocvp) && (lr = -1))
- || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
+ } else if (((cvp && amtp->fallback > AMGfallNEVER)
+ || (ocvp && oamtp->fallback > AMGfallNEVER))
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
off = scmp_amg;
break;
}
- if ((off != -1) && (cv = cvp[off]))
+ if (off != -1) {
+ if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
+ cv = ocvp[off];
+ lr = -1;
+ }
+ if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
+ cv = cvp[off];
+ lr = 1;
+ }
+ }
+ if (cv)
postpr = 1;
else
goto not_found;
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
- } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+ } else if ((use_default_op =
+ (!ocvp || oamtp->fallback >= AMGfallYES)
+ && (!cvp || amtp->fallback >= AMGfallYES))
+ && !DEBUG_o_TEST) {
/* Skip generating the "no method found" message. */
return NULL;
} else {
SvAMAGIC(right)?
HvNAME_get(SvSTASH(SvRV(right))):
""));
- if (amtp && amtp->fallback >= AMGfallYES) {
+ if (use_default_op) {
DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
if (( (method + assignshift == off)
&& (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_CALLunary(left,copy_amg))) {
+ SvRV_set(left, rv_copy);
+ SvSETMAGIC(left);
+ SvREFCNT_dec(tmpRef);
+ }
+ }
+
{
dSP;
BINOP myop;
if (PERLDB_SUB && PL_curstash != PL_debstash)
PL_op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ Perl_pp_pushmark(aTHX);
EXTEND(SP, notfound + 5);
PUSHs(lr>0? right: left);
/*
=for apidoc gv_try_downgrade
-If C<gv> is a typeglob containing only a constant sub, and is only
-referenced from its package, and both the typeglob and the sub are
-sufficiently ordinary, replace the typeglob (in the package) with a
-placeholder that more compactly represents the same thing. This is meant
-to be used when a placeholder has been upgraded, most likely because
-something wanted to look at a proper code object, and it has turned out
-to be a constant sub to which a proper reference is no longer required.
+If the typeglob C<gv> can be expressed more succinctly, by having
+something other than a real GV in its place in the stash, replace it
+with the optimised form. Basic requirements for this are that C<gv>
+is a real typeglob, is sufficiently ordinary, and is only referenced
+from its package. This function is meant to be used when a GV has been
+looked up in part to see what was there, causing upgrading, but based
+on what was found it turns out that the real GV isn't required after all.
+
+If C<gv> is a completely empty typeglob, it is deleted from the stash.
+
+If C<gv> is a typeglob containing only a sufficiently-ordinary constant
+sub, the typeglob is replaced with a scalar-reference placeholder that
+more compactly represents the same thing.
=cut
*/
HEK *namehek;
SV **gvp;
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
- if (SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
- !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+
+ /* 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) && !SvREADONLY(gv) &&
isGV_with_GP(gv) && GvGP(gv) &&
- GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+ !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
- GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(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);
+ (void)hv_delete(stash, HEK_KEY(gvnhek),
+ HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
+ } else if (GvMULTI(gv) && cv &&
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
CvSTASH(cv) == stash && CvGV(cv) == gv &&
CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
https://perl5.git.perl.org / perl5.git / blobdiff