#ifndef USE_ITHREADS
SV * temp_sv;
#endif
+ dVAR;
PERL_ARGS_ASSERT_NEWGP;
Newxz(gp, 1, GP);
if (oldgv) {
if (CvCVGV_RC(cv)) {
- SvREFCNT_dec(oldgv);
+ SvREFCNT_dec_NN(oldgv);
CvCVGV_RC_off(cv);
}
else {
static const char file[] = __FILE__;
CV *cv, *oldcompcv = NULL;
int opnum = 0;
- SV *opnumsv;
bool ampable = TRUE; /* &{}-able */
COP *oldcurcop = NULL;
yy_parser *oldparser = NULL;
if (stash)
(void)hv_store(stash,name,len,(SV *)gv,0);
if (ampable) {
+#ifdef DEBUGGING
+ CV *orig_cv = cv;
+#endif
CvLVALUE_on(cv);
- newATTRSUB_flags(
+ /* newATTRSUB will free the CV and return NULL if we're still
+ compiling after a syntax error */
+ if ((cv = newATTRSUB_flags(
oldsavestack_ix, (OP *)gv,
NULL,NULL,
coresub_op(
code, opnum
),
1
- );
- assert(GvCV(gv) == cv);
- if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
- && opnum != OP_UNDEF)
- CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+ )) != NULL) {
+ assert(GvCV(gv) == orig_cv);
+ if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+ && opnum != OP_UNDEF)
+ CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+ }
LEAVE;
PL_parser = oldparser;
PL_curcop = oldcurcop;
PL_compcv = oldcompcv;
}
- opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
- cv_set_call_checker(
- cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
- );
- SvREFCNT_dec(opnumsv);
+ if (cv) {
+ SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+ cv_set_call_checker(
+ cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+ );
+ SvREFCNT_dec(opnumsv);
+ }
+
return gv;
}
}
else {
/* stale cache entry, junk it and move on */
- SvREFCNT_dec(cand_cv);
+ SvREFCNT_dec_NN(cand_cv);
GvCV_set(topgv, NULL);
cand_cv = NULL;
GvCVGEN(topgv) = 0;
return gv;
}
Perl_croak(aTHX_
- "Can't locate object method \"%"SVf
+ "Can't locate object method \"%"UTF8f
"\" via package \"%"HEKf"\"",
- SVfARG(newSVpvn_flags(name, nend - name,
- SVs_TEMP | is_utf8)),
+ UTF8fARG(is_utf8, nend - name, name),
HEKfARG(HvNAME_HEK(stash)));
}
else {
packnamesv = newSVpvn_flags(origname, nsplit - origname,
SVs_TEMP | is_utf8);
} else {
- packnamesv = sv_2mortal(newSVsv(error_report));
+ packnamesv = error_report;
}
Perl_croak(aTHX_
- "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
+ "Can't locate object method \"%"UTF8f
+ "\" via package \"%"SVf"\""
" (perhaps you forgot to load \"%"SVf"\"?)",
- SVfARG(newSVpvn_flags(name, nend - name,
- SVs_TEMP | is_utf8)),
+ UTF8fARG(is_utf8, nend - name, name),
SVfARG(packnamesv), SVfARG(packnamesv));
}
}
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+ "Use of inherited AUTOLOAD for non-method %"SVf
+ "::%"UTF8f"() is deprecated",
SVfARG(packname),
- SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+ UTF8fARG(is_utf8, len, name));
if (CvISXSUB(cv)) {
/* Instead of forcing the XSUB do another lookup for $AUTOLOAD
*/
CvSTASH_set(cv, stash);
if (SvPOK(cv)) { /* Ouch! */
- SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
+ SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
STRLEN ulen;
const char *proto = CvPROTO(cv);
assert(proto);
SvTEMP_on(tmpsv); /* Allow theft */
sv_setsv_nomg((SV *)cv, tmpsv);
SvTEMP_off(tmpsv);
- SvREFCNT_dec(tmpsv);
+ SvREFCNT_dec_NN(tmpsv);
SvLEN(cv) = SvCUR(cv) + 1;
SvCUR(cv) = ulen;
}
type, varname, SVfARG(namesv), methpv);
LEAVE;
}
- else SvREFCNT_dec(namesv);
+ else SvREFCNT_dec_NN(namesv);
return stash;
}
const char *name = nambeg;
GV *gv = NULL;
GV**gvp;
- I32 len;
+ STRLEN len;
const char *name_cursor;
HV *stash = NULL;
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
if (!stash) {
no_stash:
- if (len && isIDFIRST_lazy(name)) {
+ if (len && isIDFIRST_lazy_if(name, is_utf8)) {
bool global = FALSE;
switch (len) {
(sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
- SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
/* diag_listed_as: Variable "%s" is not imported%s */
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "Variable \"%c%"SVf"\" is not imported",
+ "Variable \"%c%"UTF8f"\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
- SVfARG(namesv));
+ UTF8fARG(is_utf8, len, name));
if (GvCVu(*gvp))
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
+ "\t(Did you mean &%"UTF8f" instead?)\n",
+ UTF8fARG(is_utf8, len, name)
);
stash = NULL;
}
/* By this point we should have a stash and a name */
if (!stash) {
- if (add) {
+ if (add && !PL_in_clean_all) {
SV * const err = Perl_mess(aTHX_
- "Global symbol \"%s%"SVf"\" requires explicit package name",
+ "Global symbol \"%s%"UTF8f
+ "\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+ : ""), UTF8fARG(is_utf8, len, name));
GV *gv;
- if (USE_UTF8_IN_NAMES)
+ if (is_utf8)
SvUTF8_on(err);
qerror(err);
gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
if (add) {
GvMULTI_on(gv);
gv_init_svtype(gv, sv_type);
+ /* You reach this path once the typeglob has already been created,
+ either by the same or a different sigil. If this path didn't
+ exist, then (say) referencing $! first, and %! second would
+ mean that %! was not handled correctly. */
if (len == 1 && stash == PL_defstash) {
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
- }
+ } else if (sv_type == SVt_PV) {
+ if (*name == '*' || *name == '#') {
+ /* diag_listed_as: $* is no longer supported */
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+ WARN_SYNTAX),
+ "$%c is no longer supported", *name);
+ }
+ }
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
case '[':
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
break;
+#ifdef PERL_SAWAMPERSAND
case '`':
PL_sawampersand |= SAWAMPERSAND_LEFT;
(void)GvSVn(gv);
PL_sawampersand |= SAWAMPERSAND_RIGHT;
(void)GvSVn(gv);
break;
+#endif
}
}
}
faking_it = SvOK(gv);
if (add & GV_ADDWARN)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
- SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "Had to create %"UTF8f" unexpectedly",
+ UTF8fARG(is_utf8, name_end-nambeg, nambeg));
gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
if ( isIDFIRST_lazy_if(name, is_utf8)
case '&': /* $& */
case '`': /* $` */
case '\'': /* $' */
+#ifdef PERL_SAWAMPERSAND
if (!(
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
? SAWAMPERSAND_MIDDLE
: SAWAMPERSAND_RIGHT;
}
+#endif
goto magicalize;
case ':': /* $: */
GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
))
(void)hv_store(stash,name,len,(SV *)gv,0);
- else SvREFCNT_dec(gv), gv = NULL;
+ else SvREFCNT_dec_NN(gv), gv = NULL;
}
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
{
dVAR;
PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
+ assert(!(flags & ~SVf_UTF8));
- return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
- SVfARG(newSVpvn_flags(pack, strlen(pack),
- SVs_TEMP | flags)),
+ return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
+ UTF8fARG(flags, strlen(pack), pack),
(long)PL_gensym++),
GV_ADD, SVt_PVGV);
}
/* If the GP they asked for a reference to contains
a method cache entry, clear it first, so that we
don't infect them with our cached entry */
- SvREFCNT_dec(gp->gp_cv);
+ SvREFCNT_dec_NN(gp->gp_cv);
gp->gp_cv = NULL;
gp->gp_cvgen = 0;
}
for (i = 1; i < NofAMmeth; i++) {
CV * const cv = amtp->table[i];
if (cv) {
- SvREFCNT_dec(MUTABLE_SV(cv));
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
amtp->table[i] = NULL;
}
}
if (mg) {
const AMT * const amtp = (AMT*)mg->mg_ptr;
if (amtp->was_ok_sub == newgen) {
- return AMT_OVERLOADED(amtp) ? 1 : 0;
+ return AMT_AMAGIC(amtp) ? 1 : 0;
}
sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
}
amt.flags = 0;
{
- int filled = 0, have_ovl = 0;
- int i, lim = 1;
+ int filled = 0;
+ int i;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
if (!gv)
{
if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
- lim = DESTROY_amg; /* Skip overloading entries. */
+ goto no_table;
}
#ifdef PERL_DONT_CREATE_GVSV
else if (!sv) {
else if (SvOK(sv)) {
amt.fallback=AMGfallNEVER;
filled = 1;
- have_ovl = 1;
}
else {
filled = 1;
- have_ovl = 1;
}
- for (i = 1; i < lim; i++)
- amt.table[i] = NULL;
- for (; i < NofAMmeth; i++) {
+ for (i = 1; i < NofAMmeth; i++) {
const char * const cooky = PL_AMG_names[i];
/* Human-readable form, for debugging: */
- const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+ const char * const cp = AMG_id2name(i);
const STRLEN l = PL_AMG_namelens[i];
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
then we could have created stubs for "(+0" in A and C too.
But if B overloads "bool", we may want to use it for
numifying instead of C's "+0". */
- if (i >= DESTROY_amg)
- gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
- else /* Autoload taken care of below */
- gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
+ gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
if (gv && (cv = GvCV(gv))) {
if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
GvNAME(CvGV(cv))) );
filled = 1;
- if (i < DESTROY_amg)
- have_ovl = 1;
} else if (gv) { /* Autoloaded... */
cv = MUTABLE_CV(gv);
filled = 1;
}
if (filled) {
AMT_AMAGIC_on(&amt);
- if (have_ovl)
- AMT_OVERLOADED_on(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMT));
- return have_ovl;
+ return TRUE;
}
}
/* Here we have no table: */
- /* no_table: */
+ no_table:
AMT_AMAGIC_off(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMTS));
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
if (!mg) {
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, 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 */
- if (id == DESTROY_amg) {
- GV * const gv = gv_fetchmethod(stash, "DESTROY");
- if (gv)
- return GvCV(gv);
- }
+ if (Gv_AMupdate(stash, 0) == -1)
return NULL;
- }
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
}
assert(mg);
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: NULL))
- && ((cv = cvp[off=method+assignshift])
- || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
- * usual method */
- (
-#ifdef DEBUGGING
- fl = 1,
-#endif
- cv = cvp[off=method])))) { /* Method for right
- * argument found */
- lr=1;
+ && (cv = cvp[off=method])) { /* Method for right
+ * argument found */
+ lr=1;
} else if (((cvp && amtp->fallback > AMGfallNEVER)
|| (ocvp && oamtp->fallback > AMGfallNEVER))
&& !(flags & AMGf_unary)) {
if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
SvRV_set(left, rv_copy);
SvSETMAGIC(left);
- SvREFCNT_dec(tmpRef);
+ SvREFCNT_dec_NN(tmpRef);
}
}
HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
*gvp == (SV*)gv) {
SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+ const bool imported = !!GvIMPORTED_CV(gv);
SvREFCNT(gv) = 0;
sv_clear((SV*)gv);
SvREFCNT(gv) = 1;
- SvFLAGS(gv) = SVt_IV|SVf_ROK;
+ SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
STRUCT_OFFSET(XPVIV, xiv_iv));
SvRV_set(gv, value);