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));
/* newCONSTSUB takes ownership of the reference from us. */
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);
} else {
(void) start_subparse(0,0); /* Create empty CV in compcv. */
cv = PL_compcv;
- GvCV(gv) = cv;
+ GvCV_set(gv,cv);
}
LEAVE;
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));
varsv = GvSVn(vargv);
sv_setpvn(varsv, packname, packname_len);
sv_catpvs(varsv, "::");
- sv_catpvn(varsv, name, len);
+ /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
+ tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
+ sv_catpvn_mg(varsv, name, 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.
if (!tmpgv)
return NULL;
stash = GvHV(tmpgv);
+ if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
assert(stash);
- assert(HvNAME_get(stash));
+ if (!HvNAME_get(stash)) {
+ hv_name_set(stash, name, namelen, 0);
+
+ /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
+ /* If the containing stash has multiple effective
+ names, see that this one gets them, too. */
+ if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
+ mro_package_moved(stash, NULL, tmpgv, 1);
+ }
return stash;
}
return NULL;
len = name_cursor - name;
- if (len > 0) {
+ if (name_cursor > nambeg) { /* Skip for initial :: or ' */
const char *key;
if (*name_cursor == ':') {
key = name;
GvMULTI_on(gv);
}
if (key != name)
- Safefree((char *)key);
+ 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);
}
if (*name_cursor == ':')
name_cursor++;
- name_cursor++;
- name = name_cursor;
+ name = name_cursor+1;
if (name == name_end)
return gv
? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
if (add) {
GvMULTI_on(gv);
gv_init_sv(gv, sv_type);
- if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+ if (len == 1 && stash == PL_defstash
+ && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
#endif
goto magicalize;
+ case '$': /* $$ */
+ SvREADONLY_on(GvSVn(gv));
+ goto magicalize;
case '!': /* $! */
GvMULTI_on(gv);
/* If %! has been used, automatically load Errno.pm. */
{
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 */
return TRUE;
}
}
+ if(left==right && SvGMAGICAL(left)) {
+ SV * const left = sv_newmortal();
+ *(sp-1) = left;
+ /* Print the uninitialized warning now, so it includes the vari-
+ able name. */
+ if (!SvOK(right)) {
+ if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
+ sv_setsv_flags(left, &PL_sv_no, 0);
+ }
+ else sv_setsv_flags(left, right, 0);
+ SvGETMAGIC(right);
+ }
if (flags & AMGf_numeric) {
- if (SvROK(left))
- *(sp-1) = sv_2num(left);
+ if (SvROK(TOPm1s))
+ *(sp-1) = sv_2num(TOPm1s);
if (SvROK(right))
*sp = sv_2num(right);
}
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
&& (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));
* information by hand */
SV *tmpRef = SvRV(left);
SV *rv_copy;
- if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLun(left,copy))) {
+ if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
SvRV_set(left, rv_copy);
SvSETMAGIC(left);
SvREFCNT_dec(tmpRef);
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);
/* 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) &&
https://perl5.git.perl.org / perl5.git / blobdiff