if (SvTYPE(gv) == SVt_PVGV)
return cv_const_sv(GvCVu(gv));
- return SvROK(gv) ? SvRV(gv) : NULL;
+ return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
}
GP *
const char *file;
STRLEN len;
#ifndef USE_ITHREADS
- SV * temp_sv;
+ GV *filegv;
#endif
dVAR;
gp->gp_sv = newSV(0);
#endif
-#ifdef USE_ITHREADS
+ /* PL_curcop should never be null here. */
+ assert(PL_curcop);
+ /* But for non-debugging builds play it safe */
if (PL_curcop) {
gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+#ifdef USE_ITHREADS
if (CopFILE(PL_curcop)) {
file = CopFILE(PL_curcop);
len = strlen(file);
}
+#else
+ filegv = CopFILEGV(PL_curcop);
+ if (filegv) {
+ file = GvNAME(filegv)+2;
+ len = GvNAMELEN(filegv)-2;
+ }
+#endif
else goto no_file;
}
else {
file = "";
len = 0;
}
-#else
- if(PL_curcop)
- gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
- temp_sv = CopFILESV(PL_curcop);
- if (temp_sv) {
- file = SvPVX(temp_sv);
- len = SvCUR(temp_sv);
- } else {
- file = "";
- len = 0;
- }
-#endif
PERL_HASH(hash, file, len);
gp->gp_file_hek = share_hek(file, len, hash);
if (has_constant) {
/* The constant has to be a simple scalar type. */
switch (SvTYPE(has_constant)) {
- case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVFM:
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
if (flags & GV_SUPER) {
- if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
- cachestash = HvAUX(stash)->xhv_super;
+ if (!HvAUX(stash)->xhv_mro_meta->super)
+ HvAUX(stash)->xhv_mro_meta->super = newHV();
+ cachestash = HvAUX(stash)->xhv_mro_meta->super;
}
else cachestash = stash;
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
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);
(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;
}
if (!stash) {
if (add && !PL_in_clean_all) {
- SV * const namesv = newSVpvn_flags(name, len, is_utf8);
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(namesv));
+ : ""), UTF8fARG(is_utf8, len, name));
GV *gv;
- SvREFCNT_dec_NN(namesv);
if (is_utf8)
SvUTF8_on(err);
qerror(err);
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 && *name == '#') {
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$# is no longer supported");
- }
- if (*name == '*') {
- if (sv_type == SVt_PV)
+ } 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),
- "$* is no longer supported, and will become a syntax error");
- else
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "%c* is deprecated, and will become a syntax error",
- sv_type == SVt_PVAV ? '@'
- : sv_type == SVt_PVCV ? '&'
- : sv_type == SVt_PVHV ? '%'
- : '*');
+ "$%c is no longer supported", *name);
+ }
}
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
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 '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto magicalize;
+ break;
case '\017': /* $^OPEN */
if (strEQ(name2, "PEN"))
goto magicalize;
break;
}
case '*': /* $* */
- if (sv_type == SVt_PV)
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$* is no longer supported, and will become a syntax error");
- else {
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "%c* is deprecated, and will become a syntax error",
- sv_type == SVt_PVAV ? '@'
- : sv_type == SVt_PVCV ? '&'
- : sv_type == SVt_PVHV ? '%'
- : '*');
- }
- break;
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$# is no longer supported");
+ "$%c is no longer supported", *name);
break;
case '\010': /* $^H */
{
}
void
-Perl_gv_check(pTHX_ const HV *stash)
+Perl_gv_check(pTHX_ HV *stash)
{
dVAR;
I32 i;
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
+ /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
+ are currently searching through recursively. */
+ SvIsCOW_on(stash);
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
{
- if (hv != PL_defstash && hv != stash)
+ if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
gv_check(hv); /* nested package */
}
else if ( *HeKEY(entry) != '_'
HEKfARG(GvNAME_HEK(gv)));
}
}
+ SvIsCOW_off(stash);
}
}
{
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);
}
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);