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));
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
sv_reftype(has_constant, 0));
+ NOT_REACHED; /* NOTREACHED */
break;
default: NOOP;
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);
- if (CvSTASH(cv) == stash && (
+ if (CvNAMED(cv) && CvSTASH(cv) == stash && (
CvNAME_HEK(cv) == GvNAME_HEK(gv)
|| ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
&& HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
PL_compcv = oldcompcv;
}
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);
+ SV *opnumsv = newSViv(
+ (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
+ (OP_ENTEREVAL | (1<<16))
+ : opnum ? opnum : (((I32)name[2]) << 16));
+ cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
+ SvREFCNT_dec_NN(opnumsv);
}
return gv;
STRLEN namelen;
PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
if (LIKELY(SvPOK_nog(namesv))) /* common case */
- return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
+ return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
+ flags | SvUTF8(namesv));
namepv = SvPV(namesv, namelen);
if (SvUTF8(namesv)) flags |= SVf_UTF8;
return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
/* check locally for a real method or a cache entry */
he = (HE*)hv_common(
- cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
+ cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
);
if (he) gvp = (GV**)&HeVAL(he);
else gvp = NULL;
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
);
return NULL;
/*
- * Inheriting AUTOLOAD for non-methods works ... for now.
+ * Inheriting AUTOLOAD for non-methods no longer works
*/
if (
!(flags & GV_AUTOLOAD_ISMETHOD)
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %" SVf
- "::%" UTF8f "() is deprecated. This will be "
- "fatal in Perl 5.28",
+ Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
+ "::%" UTF8f "() is no longer allowed",
SVfARG(packname),
UTF8fARG(is_utf8, len, name));
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 {
GV **gvp;
dSP;
+ 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;
call_sv((SV *)*gvp, G_VOID|G_DISCARD);
LEAVE;
+ POPSTACK;
}
}
(flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
);
- if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
+ if (he) {
+ SV *sv = HeVAL(he);
+ HV *hv;
+ assert(SvIOK(sv));
+ hv = INT2PTR(HV*, SvIVX(sv));
+ assert(SvTYPE(hv) == SVt_PVHV);
+ return hv;
+ }
else if (flags & GV_CACHE_ONLY) return NULL;
if (namesv) {
STRLEN *len, const char *nambeg, STRLEN full_len,
const U32 is_utf8, const I32 add)
{
+ char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
const char *name_cursor;
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
+ char smallbuf[64]; /* small buffer to avoid a malloc when possible */
PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
key = *name;
*len += 2;
}
- else {
+ else { /* using ' for package separator */
+ /* use our pre-allocated buffer when possible to save a malloc */
char *tmpbuf;
- Newx(tmpbuf, *len+2, char);
+ if ( *len+2 <= sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else {
+ /* only malloc once if needed */
+ if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
+ Newx(tmpfullbuf, full_len+2, char);
+ tmpbuf = tmpfullbuf;
+ }
Copy(*name, tmpbuf, *len, char);
tmpbuf[(*len)++] = ':';
tmpbuf[(*len)++] = ':';
}
gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
*gv = gvp ? *gvp : NULL;
- if (*gv && *gv != (const GV *)&PL_sv_undef) {
- if (SvTYPE(*gv) != SVt_PVGV)
- gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
- else
- GvMULTI_on(*gv);
- }
- if (key != *name)
- Safefree(key);
- if (!*gv || *gv == (const GV *)&PL_sv_undef)
+ if (!*gv || *gv == (const GV *)&PL_sv_undef) {
+ Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
return FALSE;
+ }
+ /* here we know that *gv && *gv != &PL_sv_undef */
+ if (SvTYPE(*gv) != SVt_PVGV)
+ gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
+ else
+ GvMULTI_on(*gv);
if (!(*stash = GvHV(*gv))) {
*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(
name_cursor++;
*name = name_cursor+1;
if (*name == name_end) {
- if (!*gv)
- *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (!*gv) {
+ *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+ if (SvTYPE(*gv) != SVt_PVGV) {
+ gv_init_pvn(*gv, PL_defstash, "main::", 6,
+ GV_ADDMULTI);
+ GvHV(*gv) =
+ MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
+ }
+ }
+ Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
return TRUE;
}
}
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);
}
}
/* @{^CAPTURE} %{^CAPTURE} */
if (memEQs(name, len, "\003APTURE")) {
AV* const av = GvAVn(gv);
- UV uv= *name;
+ const Size_t n = *name;
- sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
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;
}
{ /* @- @+ */
AV* const av = GvAVn(gv);
- const UV uv = (UV)*name;
+ const Size_t n = *name;
- sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
SvREADONLY_on(av);
}
break;
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
- /* diag_listed_as: $* is no longer supported */
+ /* 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", *name);
+ "$%c is no longer supported. Its use "
+ "will be fatal in Perl 5.30", *name);
break;
case '\010': /* $^H */
{
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 */
+ /* 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", *name);
+ "$%c is no longer supported. Its use "
+ "will be fatal in Perl 5.30", *name);
}
}
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
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,"::");
}
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
- const HEK * const gvhek =
- CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
+ 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. */
case abs_amg:
if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
&& ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
- SV* const nullsv=sv_2mortal(newSViv(0));
+ SV* const nullsv=&PL_sv_zero;
if (off1==lt_amg) {
SV* const lessp = amagic_call(left,nullsv,
lt_amg,AMGf_noright);
- logic = SvTRUE(lessp);
+ logic = SvTRUE_NN(lessp);
} else {
SV* const lessp = amagic_call(left,nullsv,
ncmp_amg,AMGf_noright);
case neg_amg:
if ((cv = cvp[off=subtr_amg])) {
right = left;
- left = sv_2mortal(newSViv(0));
+ left = &PL_sv_zero;
lr = 1;
}
break;
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;
case dec_amg:
SvSetSV(left,res); return left;
case not_amg:
- ans=!SvTRUE(res); break;
+ ans=!SvTRUE_NN(res); break;
default:
ans=0; break;
}
https://perl5.git.perl.org / perl5.git / blobdiff