if (!*where)
{
*where = newSV_type(type);
- if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strEQs(GvNAME(gv), "ISA"))
+ if (type == SVt_PVAV
+ && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
}
return gv;
return 0;
}
else if (stash == cachestash
- && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
- && strEQs(hvname, "CORE")
+ && len > 1 /* shortest is uc */
+ && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
assert(cstash);
- gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
+ gvp = (GV**)hv_common(
+ cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
+ );
if (!gvp) {
if (len > 1 && HvNAMELEN_get(cstash) == 4) {
const char *hvname = HvNAME(cstash); assert(hvname);
- if (strEQs(hvname, "CORE")
+ if (strBEGINs(hvname, "CORE")
&& (candidate =
S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
origname, HvENAME_get(stash), name) );
}
else if ( sep_len >= 7 &&
- strEQs(last_separator - 7, "::SUPER")) {
+ strBEGINs(last_separator - 7, "::SUPER")) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
if (stash) flags |= GV_SUPER;
/* This is the special case that exempts Foo->import and
Foo->unimport from being an error even if there's no
import/unimport subroutine */
- if (strEQ(name,"import") || strEQ(name,"unimport"))
- gv = MUTABLE_GV(&PL_sv_yes);
- else if (autoload)
+ if (strEQ(name,"import") || strEQ(name,"unimport")) {
+ gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
+ NULL, 0, 0, NULL));
+ } else if (autoload)
gv = gv_autoload_pvn(
ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
sv_setsv_nomg((SV *)cv, tmpsv);
SvTEMP_off(tmpsv);
SvREFCNT_dec_NN(tmpsv);
- SvLEN(cv) = SvCUR(cv) + 1;
+ SvLEN_set(cv, SvCUR(cv) + 1);
SvCUR(cv) = ulen;
}
else {
*stash = GvHV(*gv) = newHV();
if (!HvNAME_get(*stash)) {
if (GvSTASH(*gv) == PL_defstash && *len == 6
- && strEQs(*name, "CORE"))
+ && strBEGINs(*name, "CORE"))
hv_name_sets(*stash, "CORE", 0);
else
hv_name_set(
* a new GV.
* Note that it does not insert the GV into the stash prior to
* magicalization, which some variables require need in order
- * to work (like $[, %+, %-, %!), so callers must take care of
+ * to work (like %+, %-, %!), so callers must take care of
* that.
*
* It returns true if the gv did turn out to be magical one; i.e.,
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Avoid null warning: */
const char * const stashname = HvNAME(stash); assert(stashname);
- if (strEQs(stashname, "CORE"))
+ if (strBEGINs(stashname, "CORE"))
S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
goto storeparen;
}
break;
+ case '\023':
+ if (memEQs(name, len, "\023AFE_LOCALES"))
+ goto ro_magicalize;
+ break;
case '\024': /* ${^TAINT} */
if (memEQs(name, len, "\024AINT"))
goto ro_magicalize;
break;
case '*': /* $* */
case '#': /* $# */
- if (sv_type == SVt_PV)
- /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$%c is no longer supported. Its use "
- "will be fatal in Perl 5.30", *name);
- break;
+ if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
+ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
+ break;
case '\010': /* $^H */
{
HV *const hv = GvHVn(gv);
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
- case '[': /* $[ */
- if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
- && FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod_s(gv,'[',"arybase",0);
- }
- else goto magicalize;
- break;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
case '/': /* $/ */
case '|': /* $| */
case '$': /* $$ */
+ case '[': /* $[ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
- /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$%c is no longer supported. Its use "
- "will be fatal in Perl 5.30", *name);
+ /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
+ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
}
}
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
- case '[':
- require_tie_mod_s(gv,'[',"arybase",0);
- break;
#ifdef PERL_SAWAMPERSAND
case '`':
PL_sawampersand |= SAWAMPERSAND_LEFT;
if (len == 1 && stash == PL_defstash) {
maybe_multimagic_gv(gv, name, sv_type);
}
- else if (len == 3 && sv_type == SVt_PVAV
- && strEQs(name, "ISA")
+ else if (sv_type == SVt_PVAV
+ && memEQs(name, len, "ISA")
&& (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
gv_magicalize_isa(gv);
}
if (hv && (name = HvNAME(hv))) {
const STRLEN len = HvNAMELEN(hv);
- if (keepmain || strnNE(name, "main", len)) {
+ if (keepmain || ! memBEGINs(name, len, "main")) {
sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
sv_catpvs(sv,"::");
}
const HEK * const gvhek = CvGvNAME_HEK(cv);
const HEK * const stashek =
HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
- if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
- && stashek && HEK_LEN(stashek) == 8
- && strEQ(HEK_KEY(stashek), "overload")) {
+ if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
+ && stashek
+ && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
SV* res;
const bool oldcatch = CATCH_GET;
I32 oldmark, nret;
- U8 gimme = force_scalar ? G_SCALAR : GIMME_V;
+ /* for multiconcat, we may call overload several times,
+ * with the context of individual concats being scalar,
+ * regardless of the overall context of the multiconcat op
+ */
+ U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
+ ? G_SCALAR : GIMME_V;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
res = &PL_sv_undef;
SP = PL_stack_base + oldmark;
break;
- case G_ARRAY: {
+ case G_ARRAY:
if (flags & AMGf_want_list) {
res = sv_2mortal((SV *)newAV());
av_extend((AV *)res, nret);
break;
}
/* FALLTHROUGH */
- }
default:
res = POPs;
break;
https://perl5.git.perl.org / perl5.git / blobdiff