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;
const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
+ const bool really_sub =
+ has_constant && SvTYPE(has_constant) == SVt_PVCV;
+ COP * const old = PL_curcop;
PERL_ARGS_ASSERT_GV_INIT_PVN;
assert (!(proto && has_constant));
SvIOK_off(gv);
isGV_with_GP_on(gv);
+ if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
+ && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
+ || CvSTART(has_constant)->op_type == OP_DBSTATE))
+ PL_curcop = (COP *)CvSTART(has_constant);
GvGP_set(gv, Perl_newGP(aTHX_ gv));
+ PL_curcop = old;
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
if (flags & GV_ADDMULTI || doproto) /* doproto means it */
GvMULTI_on(gv); /* _was_ mentioned */
- if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+ if (really_sub) {
/* Not actually a constant. Just a regular sub. */
CV * const cv = (CV *)has_constant;
GvCV_set(gv,cv);
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;
}
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 {
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
-#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
+#define GET_HV_FETCH_TIE_FUNC \
+ ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
+ && *gvp \
+ && ( (isGV(*gvp) && GvCV(*gvp)) \
+ || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
+ )
/* Load the module if it is not loaded. */
if (!(stash = gv_stashpvn(name, len, 0))
- || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ || ! GET_HV_FETCH_TIE_FUNC)
{
SV * const module = newSVpvn(name, len);
const char type = varname == '[' ? '$' : '%';
if (!stash)
Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
type, varname, name);
- else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ else if (! GET_HV_FETCH_TIE_FUNC)
Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
type, varname, name);
}
/* Now call the tie function. It should be in *gvp. */
- assert(gvp); assert(*gvp); assert(GvCV(*gvp));
+ assert(gvp); assert(*gvp);
PUSHMARK(SP);
XPUSHs((SV *)gv);
PUTBACK;
*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(
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;
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