#include "perl.h"
#include "overload.c"
#include "keywords.h"
+#include "feature.h"
static const char S_autoload[] = "AUTOLOAD";
static const STRLEN S_autolen = sizeof(S_autoload)-1;
*/
what = OP_IS_DIRHOP(PL_op->op_type) ?
"dirhandle" : "filehandle";
- /* diag_listed_as: Bad symbol for filehandle */
} else if (type == SVt_PVHV) {
what = "hash";
} else {
what = type == SVt_PVAV ? "array" : "scalar";
}
+ /* diag_listed_as: Bad symbol for filehandle */
Perl_croak(aTHX_ "Bad symbol for %s", what);
}
C<stash> is the parent stash/package, if any.
-C<name> and C<len> give the name. C<flags> can be set to SVf_UTF8 for a
-UTF8 string, or the return value of SvUTF8(sv). The name must be unqualified; that is, it must not include the package name. If C<gv> is a
+C<name> and C<len> give the name. The name must be unqualified;
+that is, it must not include the package name. If C<gv> is a
stash element, it is the caller's responsibility to ensure that the name
passed to this function matches the name of the element. If it does not
match, perl's internal bookkeeping will get out of sync.
-C<multi>, when set to a true value, means to pretend that the GV has been
+C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
+the return value of SvUTF8(sv). It can also take the
+GV_ADDMULTI flag, which means to pretend that the GV has been
seen before (i.e., suppress "Used once" warnings).
=for apidoc gv_init
The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
-has no flags parameter.
+has no flags parameter. If the C<multi> parameter is set, the
+GV_ADDMULTI flag will be passed to gv_init_pvn().
=for apidoc gv_init_pv
*/
void
-Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, int multi, U32 flags)
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
{
char *namepv;
STRLEN namelen;
namepv = SvPV(namesv, namelen);
if (SvUTF8(namesv))
flags |= SVf_UTF8;
- gv_init_pvn(gv, stash, namepv, namelen, multi, flags);
+ gv_init_pvn(gv, stash, namepv, namelen, flags);
}
void
-Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, int multi, U32 flags)
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
{
PERL_ARGS_ASSERT_GV_INIT_PV;
- gv_init_pvn(gv, stash, name, strlen(name), multi, flags);
+ gv_init_pvn(gv, stash, name, strlen(name), flags);
}
void
-Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi, U32 flags)
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
{
dVAR;
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
- char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+ char * const proto = (doproto && SvPOK(gv))
+ ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
+ : NULL;
const STRLEN protolen = proto ? SvCUR(gv) : 0;
+ 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;
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 (multi || doproto) /* doproto means it _was_ mentioned */
- GvMULTI_on(gv);
+ if (flags & GV_ADDMULTI || doproto) /* doproto means it */
+ GvMULTI_on(gv); /* _was_ mentioned */
if (doproto) { /* Replicate part of newSUB here. */
CV *cv;
ENTER;
if (has_constant) {
- char *name0 = NULL;
- if (name[len])
- /* newCONSTSUB doesn't take a len arg, so make sure we
- * give it a \0-terminated string */
- name0 = savepvn(name,len);
-
/* newCONSTSUB takes ownership of the reference from us. */
- cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+ cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
/* In case op.c:S_process_special_blocks stole it: */
if (!GvCV(gv))
GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
- if (name0)
- Safefree(name0);
/* If this reference was a copy of another, then the subroutine
must have been "imported", by a Perl space assignment to a GV
from a reference to CV. */
if (proto) {
sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
+ if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
}
}
static GV *
S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
- const char * const name, const STRLEN len,
- const char * const fullname, STRLEN const fullen)
+ const char * const name, const STRLEN len)
{
const int code = keyword(name, len, 1);
static const char file[] = __FILE__;
- CV *cv, *oldcompcv;
+ CV *cv, *oldcompcv = NULL;
int opnum = 0;
SV *opnumsv;
bool ampable = TRUE; /* &{}-able */
- COP *oldcurcop;
- yy_parser *oldparser;
- I32 oldsavestack_ix;
+ COP *oldcurcop = NULL;
+ yy_parser *oldparser = NULL;
+ I32 oldsavestack_ix = 0;
assert(gv || stash);
assert(name);
- assert(stash || fullname);
- if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
- that would require
- inlining newATTRSUB */
if (code >= 0) return NULL; /* not overridable */
switch (-code) {
/* no support for \&CORE::infix;
gv = (GV *)newSV(0);
gv_init(gv, stash, name, len, TRUE);
}
+ GvMULTI_on(gv);
if (ampable) {
ENTER;
oldcurcop = PL_curcop;
it this order as we need an op number before calling
new ATTRSUB. */
(void)core_prototype((SV *)cv, name, code, &opnum);
- if (stash && (fullname || !fullen))
+ if (stash)
(void)hv_store(stash,name,len,(SV *)gv,0);
if (ampable) {
- SV *tmpstr;
CvLVALUE_on(cv);
- if (!fullname) {
- tmpstr = newSVhek(HvENAME_HEK(stash));
- sv_catpvs(tmpstr, "::");
- sv_catpvn(tmpstr,name,len);
- }
- else tmpstr = newSVpvn_share(fullname,fullen,0);
- newATTRSUB(oldsavestack_ix,
- newSVOP(OP_CONST, 0, tmpstr),
+ newATTRSUB_flags(
+ oldsavestack_ix, (OP *)gv,
NULL,NULL,
coresub_op(
opnum
? newSVuv((UV)opnum)
: newSVpvn(name,len),
code, opnum
- )
+ ),
+ 1
);
assert(GvCV(gv) == cv);
if (opnum != OP_VEC && opnum != OP_SUBSTR)
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
/* check locally for a real method or a cache entry */
- gvp = (GV**)hv_fetch(stash, name, len, create);
+ gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
if(gvp) {
topgv = *gvp;
have_gv:
assert(topgv);
if (SvTYPE(topgv) != SVt_PVGV)
- gv_init_pvn(topgv, stash, name, len, TRUE, is_utf8);
+ gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
if ((cand_cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
}
else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
&& strnEQ(hvname, "CORE", 4)
- && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
+ && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
- basestash = gv_stashpvn(hvname, packlen, GV_ADD);
+ basestash = gv_stashpvn(hvname, packlen,
+ GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
linear_av = mro_get_linear_isa(basestash);
}
else {
cstash = gv_stashsv(linear_sv, 0);
if (!cstash) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
- SVfARG(linear_sv), hvname);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Can't locate package %"SVf" for @%"HEKf"::ISA",
+ SVfARG(linear_sv),
+ HEKfARG(HvNAME_HEK(stash)));
continue;
}
assert(cstash);
- gvp = (GV**)hv_fetch(cstash, name, len, 0);
+ gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
if (!gvp) {
if (len > 1 && HvNAMELEN_get(cstash) == 4) {
const char *hvname = HvNAME(cstash); assert(hvname);
if (strnEQ(hvname, "CORE", 4)
&& (candidate =
- S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
+ S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
goto have_candidate;
}
have_candidate:
assert(candidate);
if (SvTYPE(candidate) != SVt_PVGV)
- gv_init_pvn(candidate, cstash, name, len, TRUE, is_utf8);
+ gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
/*
* Found real method, cache method in topgv if:
GV *
Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
{
- GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0);
+ GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
/* Have an autoload */
if (level < 0) /* Cannot do without a stub */
gv_fetchmeth_pvn(stash, name, len, 0, flags);
- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+ gvp = (GV**)hv_fetch(stash, name,
+ (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
if (!gvp)
return NULL;
return *gvp;
PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
- stash = gv_stashpvn(name, namelen, 0);
+ stash = gv_stashpvn(name, namelen, flags);
if(stash) return stash;
/* If we must create it, give it an @ISA array containing
the real package this SUPER is for, so that it's tied
into the cache invalidation code correctly */
- stash = gv_stashpvn(name, namelen, GV_ADD);
+ stash = gv_stashpvn(name, namelen, GV_ADD | flags);
gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
gv = *gvp;
- gv_init_pvn(gv, stash, "ISA", 3, TRUE, flags & SVf_UTF8);
+ gv_init(gv, stash, "ISA", 3, TRUE);
superisa = GvAVn(gv);
GvMULTI_on(gv);
sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
#ifdef USE_ITHREADS
- av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
+ av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
+ strlen(CopSTASHPV(PL_curcop)),
+ CopSTASH_flags(PL_curcop)
+ ));
#else
av_push(superisa, newSVhek(CopSTASH(PL_curcop)
? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
SV *const error_report = MUTABLE_SV(stash);
const U32 autoload = flags & GV_AUTOLOAD;
const U32 do_croak = flags & GV_CROAK;
+ const U32 is_utf8 = flags & SVf_UTF8;
PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
if (nsplit) {
if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
- SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
- CopSTASHPV(PL_curcop)));
+ SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
+ "%"HEKf"::SUPER",
+ HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
+ ));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
}
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, nsplit - origname, 0);
+ stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
/* however, explicit calls to Pkg::SUPER::method may
happen, and may require autovivification to work */
if (!stash && (nsplit - origname) >= 7 &&
strnEQ(nsplit - 7, "::SUPER", 7) &&
- gv_stashpvn(origname, nsplit - origname - 7, 0))
+ gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
stash = gv_get_super_pkg(origname, nsplit - origname, flags);
}
ostash = stash;
}
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
+ gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = MUTABLE_GV(&PL_sv_yes);
else if (autoload)
- gv = gv_autoload4(ostash, name, nend - name, TRUE);
+ gv = gv_autoload_pvn(
+ ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+ );
if (!gv && do_croak) {
/* Right now this is exclusively for the benefit of S_method_common
in pp_hot.c */
HV_FETCH_ISEXISTS, NULL, 0)
) {
require_pv("IO/File.pm");
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
+ gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
if (gv)
return gv;
}
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\"",
- name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
+ "Can't locate object method \"%"SVf
+ "\" via package \"%"HEKf"\"",
+ SVfARG(newSVpvn_flags(name, nend - name,
+ SVs_TEMP | is_utf8)),
+ HEKfARG(HvNAME_HEK(stash)));
}
else {
- STRLEN packlen;
- const char *packname;
+ SV* packnamesv;
if (nsplit) {
- packlen = nsplit - origname;
- packname = origname;
+ packnamesv = newSVpvn_flags(origname, nsplit - origname,
+ SVs_TEMP | is_utf8);
} else {
- packname = SvPV_const(error_report, packlen);
+ packnamesv = sv_2mortal(newSVsv(error_report));
}
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\""
- " (perhaps you forgot to load \"%.*s\"?)",
- name, (int)packlen, packname, (int)packlen, packname);
+ "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
+ " (perhaps you forgot to load \"%"SVf"\"?)",
+ SVfARG(newSVpvn_flags(name, nend - name,
+ SVs_TEMP | is_utf8)),
+ SVfARG(packnamesv), SVfARG(packnamesv));
}
}
}
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
- autogv = gv_autoload4(GvSTASH(stubgv),
- GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+ autogv = gv_autoload_pvn(GvSTASH(stubgv),
+ GvNAME(stubgv), GvNAMELEN(stubgv),
+ GV_AUTOLOAD_ISMETHOD
+ | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
if (autogv)
gv = autogv;
}
HV* varstash;
GV* vargv;
SV* varsv;
- const char *packname = "";
- STRLEN packname_len = 0;
+ SV *packname = NULL;
+ U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
return NULL;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
- packname = SvPV_const(MUTABLE_SV(stash), packname_len);
+ STRLEN packname_len = 0;
+ const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
+ packname = newSVpvn_flags(packname_ptr, packname_len,
+ SVs_TEMP | SvUTF8(stash));
stash = NULL;
}
- else {
- packname = HvNAME_get(stash);
- packname_len = HvNAMELEN_get(stash);
- }
+ else
+ packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
}
- if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
+ if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
return NULL;
cv = GvCV(gv);
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
- packname, (int)len, name);
+ "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+ SVfARG(packname),
+ SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
if (CvISXSUB(cv)) {
- /* rather than lookup/init $AUTOLOAD here
- * only to have the XSUB do another lookup for $AUTOLOAD
- * and split that value on the last '::',
- * pass along the same data via some unused fields in the CV
+ /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
+ * and split that value on the last '::', pass along the same data
+ * via the SvPVX field in the CV, and the stash in CvSTASH.
+ *
+ * Due to an unfortunate accident of history, the SvPVX field
+ * serves two purposes. It is also used for the subroutine's pro-
+ * type. Since SvPVX has been documented as returning the sub name
+ * for a long time, but not as returning the prototype, we have
+ * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
+ * elsewhere.
+ *
+ * We put the prototype in the same allocated buffer, but after
+ * the sub name. The SvPOK flag indicates the presence of a proto-
+ * type. The CvAUTOLOAD flag indicates the presence of a sub name.
+ * If both flags are on, then SvLEN is used to indicate the end of
+ * the prototype (artificially lower than what is actually allo-
+ * cated), at the risk of having to reallocate a few bytes unneces-
+ * sarily--but that should happen very rarely, if ever.
+ *
+ * We use SvUTF8 for both prototypes and sub names, so if one is
+ * UTF8, the other must be upgraded.
*/
CvSTASH_set(cv, stash);
- SvPV_set(cv, (char *)name); /* cast to lose constness warning */
- SvCUR_set(cv, len);
- return gv;
+ if (SvPOK(cv)) { /* Ouch! */
+ SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
+ STRLEN ulen;
+ const char *proto = CvPROTO(cv);
+ assert(proto);
+ if (SvUTF8(cv))
+ sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
+ ulen = SvCUR(tmpsv);
+ SvCUR(tmpsv)++; /* include null in string */
+ sv_catpvn_flags(
+ tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
+ );
+ SvTEMP_on(tmpsv); /* Allow theft */
+ sv_setsv_nomg((SV *)cv, tmpsv);
+ SvTEMP_off(tmpsv);
+ SvREFCNT_dec(tmpsv);
+ SvLEN(cv) = SvCUR(cv) + 1;
+ SvCUR(cv) = ulen;
+ }
+ else {
+ sv_setpvn((SV *)cv, name, len);
+ SvPOK_off(cv);
+ if (is_utf8)
+ SvUTF8_on(cv);
+ else SvUTF8_off(cv);
+ }
+ CvAUTOLOAD_on(cv);
}
/*
ENTER;
if (!isGV(vargv)) {
- gv_init_pvn(vargv, varstash, S_autoload, S_autolen, FALSE, 0);
+ gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
#ifdef PERL_DONT_CREATE_GVSV
GvSV(vargv) = newSV(0);
#endif
}
LEAVE;
varsv = GvSVn(vargv);
- sv_setpvn(varsv, packname, packname_len);
+ sv_setsv(varsv, packname);
sv_catpvs(varsv, "::");
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
- sv_catpvn_mg(varsv, name, len);
+ sv_catpvn_flags(
+ varsv, name, len,
+ SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+ );
+ if (is_utf8)
+ SvUTF8_on(varsv);
return gv;
}
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
- if (!stash || !(gv_fetchmethod(stash, methpv))) {
+ if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
SV *module = newSVsv(namesv);
char varname = *varpv; /* varpv might be clobbered by load_module,
so save it. For the moment it's always
a single char. */
+ const char type = varname == '[' ? '$' : '%';
dSP;
ENTER;
if ( flags & 1 )
SPAGAIN;
stash = gv_stashsv(namesv, 0);
if (!stash)
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
- varname, SVfARG(namesv));
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
+ type, varname, SVfARG(namesv));
else if (!gv_fetchmethod(stash, methpv))
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
- varname, SVfARG(namesv), methpv);
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
+ type, varname, SVfARG(namesv), methpv);
}
SvREFCNT_dec(namesv);
return stash;
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
assert(stash);
if (!HvNAME_get(stash)) {
- hv_name_set(stash, name, namelen, 0);
+ hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
/* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
/* If the containing stash has multiple effective
PERL_ARGS_ASSERT_GV_STASHSV;
- return gv_stashpvn(ptr, len, flags);
+ return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
}
goto no_stash;
}
- if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
+ if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
/* accidental stringify on a GV? */
name++;
}
tmpbuf[len++] = ':';
key = tmpbuf;
}
- gvp = (GV**)hv_fetch(stash, key, len, add);
+ gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : 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);
+ gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
else
GvMULTI_on(gv);
}
hv_name_set(stash, "CORE", 4, 0);
else
hv_name_set(
- stash, nambeg, name_cursor-nambeg, 0
+ stash, nambeg, name_cursor-nambeg, is_utf8
);
/* If the containing stash has multiple effective
names, see that this one gets them, too. */
}
}
else if (!HvNAME_get(stash))
- hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
+ hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
}
if (*name_cursor == ':')
!(len == 1 && sv_type == SVt_PV &&
(*name == 'a' || *name == 'b')) )
{
- gvp = (GV**)hv_fetch(stash,name,len,0);
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
if (!gvp ||
*gvp == (const GV *)&PL_sv_undef ||
SvTYPE(*gvp) != SVt_PVGV)
(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%s\" is not imported",
+ "Variable \"%c%"SVf"\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
- name);
+ SVfARG(namesv));
if (GvCVu(*gvp))
Perl_ck_warner_d(
aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean &%s instead?)\n", name
+ "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
);
stash = NULL;
}
if (!stash) {
if (add) {
SV * const err = Perl_mess(aTHX_
- "Global symbol \"%s%s\" requires explicit package name",
+ "Global symbol \"%s%"SVf"\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), name);
+ : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
GV *gv;
if (USE_UTF8_IN_NAMES)
SvUTF8_on(err);
if (!SvREFCNT(stash)) /* symbol table under destruction */
return NULL;
- gvp = (GV**)hv_fetch(stash,name,len,add);
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
if (addmg) gv = (GV *)newSV(0);
else return NULL;
if (add) {
GvMULTI_on(gv);
gv_init_svtype(gv, sv_type);
- if (len == 1 && stash == PL_defstash
- && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+ 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);
+ }
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ if (*name == '[')
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ else if (*name == '&' || *name == '`' || *name == '\'') {
+ PL_sawampersand = TRUE;
+ (void)GvSVn(gv);
+ }
+ }
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
faking_it = SvOK(gv);
if (add & GV_ADDWARN)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
- gv_init_pvn(gv, stash, name, len, add & GV_ADDMULTI, is_utf8);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
+ SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
+ gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
- if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
- : (PL_dowarn & G_WARN_ON ) ) )
+ if ( isIDFIRST_lazy_if(name, is_utf8)
+ && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
GvMULTI_on(gv) ;
/* set up magic where warranted */
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Avoid null warning: */
const char * const stashname = HvNAME(stash); assert(stashname);
- if (strnEQ(stashname, "CORE", 4)
- && S_maybe_add_coresub(aTHX_
- addmg ? stash : 0, gv, name, len, nambeg, full_len
- ))
- addmg = 0;
+ if (strnEQ(stashname, "CORE", 4))
+ S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
else if (len > 1) {
case '&': /* $& */
case '`': /* $` */
case '\'': /* $' */
- if (
+ if (!(
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
sv_type == SVt_PVCV ||
sv_type == SVt_PVFM ||
sv_type == SVt_PVIO
- ) { break; }
- PL_sawampersand = TRUE;
+ )) { PL_sawampersand = TRUE; }
goto magicalize;
case ':': /* $: */
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ }
break;
case '-': /* $- */
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ }
break;
}
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"$%c is no longer supported", *name);
break;
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
+ case '[': /* $[ */
+ if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+ && FEATURE_ARYBASE_IS_ENABLED) {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ addmg = 0;
+ }
+ else goto magicalize;
+ break;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
case '7': /* $7 */
case '8': /* $8 */
case '9': /* $9 */
- case '[': /* $[ */
case '^': /* $^ */
case '~': /* $~ */
case '=': /* $= */
void
Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- SV *name;
+ const char *name;
const HV * const hv = GvSTASH(gv);
PERL_ARGS_ASSERT_GV_FULLNAME4;
- if (!hv) {
- SvOK_off(sv);
- return;
- }
sv_setpv(sv, prefix ? prefix : "");
- name = HvNAME_get(hv)
- ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
- : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
-
- if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
- sv_catsv(sv,name);
+ if (hv && (name = HvNAME(hv))) {
+ const STRLEN len = HvNAMELEN(hv);
+ if (keepmain || strnNE(name, "main", len)) {
+ sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
sv_catpvs(sv,"::");
+ }
}
+ else sv_catpvs(sv,"__ANON__::");
sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
}
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
}
- else if (isALPHA(*HeKEY(entry))) {
+ else if ( *HeKEY(entry) != '_'
+ && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
const char *file;
gv = MUTABLE_GV(HeVAL(entry));
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
= gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
#endif
Perl_warner(aTHX_ packWARN(WARN_ONCE),
- "Name \"%s::%s\" used only once: possible typo",
- HvNAME_get(stash), GvNAME(gv));
+ "Name \"%"HEKf"::%"HEKf
+ "\" used only once: possible typo",
+ HEKfARG(HvNAME_HEK(stash)),
+ HEKfARG(GvNAME_HEK(gv)));
}
}
}
/* FIXME - another reference loop GV -> symtab -> GV ?
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
- const char *hvname = HvNAME_get(hv);
- if (PL_stashcache && hvname)
- (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
- G_DISCARD);
+ const HEK *hvname_hek = HvNAME_HEK(hv);
+ if (PL_stashcache && hvname_hek)
+ (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
+ (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
+ G_DISCARD);
SvREFCNT_dec(hv);
}
SvREFCNT_dec(io);
return -1;
}
else {
- const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
- Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
- "in package \"%.256s\"",
+ const SV * const name = (gvsv && SvPOK(gvsv))
+ ? gvsv
+ : newSVpvs_flags("???", SVs_TEMP);
+ /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
+ Perl_croak(aTHX_ "%s method \"%"SVf256
+ "\" overloading \"%s\" "\
+ "in package \"%"HEKf256"\"",
(GvCVGEN(gv) ? "Stub found while resolving"
: "Can't resolve"),
- name, cp, HvNAME(stash));
+ SVfARG(name), cp,
+ HEKfARG(
+ HvNAME_HEK(stash)
+ ));
}
}
cv = GvCV(gv = ngv);
return tmpsv ? tmpsv : ref;
}
+bool
+Perl_amagic_is_enabled(pTHX_ int method)
+{
+ SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
+
+ assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
+
+ if ( !lex_mask || !SvOK(lex_mask) )
+ /* overloading lexically disabled */
+ return FALSE;
+ else if ( lex_mask && SvPOK(lex_mask) ) {
+ /* we have an entry in the hints hash, check if method has been
+ * masked by overloading.pm */
+ STRLEN len;
+ const int offset = method / 8;
+ const int bit = method % 8;
+ char *pv = SvPV(lex_mask, len);
+
+ /* Bit set, so this overloading operator is disabled */
+ if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+ return FALSE;
+ }
+ return TRUE;
+}
+
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
PERL_ARGS_ASSERT_AMAGIC_CALL;
if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
- SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
-
- if ( !lex_mask || !SvOK(lex_mask) )
- /* overloading lexically disabled */
- return NULL;
- else if ( lex_mask && SvPOK(lex_mask) ) {
- /* we have an entry in the hints hash, check if method has been
- * masked by overloading.pm */
- STRLEN len;
- const int offset = method / 8;
- const int bit = method % 8;
- char *pv = SvPV(lex_mask, len);
-
- /* Bit set, so this overloading operator is disabled */
- if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
- return NULL;
- }
+ if (!amagic_is_enabled(method)) return NULL;
}
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
SV *msg;
if (off==-1) off=method;
msg = sv_2mortal(Perl_newSVpvf(aTHX_
- "Operation \"%s\": no method found,%sargument %s%s%s%s",
- AMG_id2name(method + assignshift),
- (flags & AMGf_unary ? " " : "\n\tleft "),
- SvAMAGIC(left)?
- "in overloaded package ":
- "has no overloaded magic",
- SvAMAGIC(left)?
- HvNAME_get(SvSTASH(SvRV(left))):
- "",
- SvAMAGIC(right)?
- ",\n\tright argument in overloaded package ":
- (flags & AMGf_unary
- ? ""
- : ",\n\tright argument has no overloaded magic"),
- SvAMAGIC(right)?
- HvNAME_get(SvSTASH(SvRV(right))):
- ""));
+ "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
+ AMG_id2name(method + assignshift),
+ (flags & AMGf_unary ? " " : "\n\tleft "),
+ SvAMAGIC(left)?
+ "in overloaded package ":
+ "has no overloaded magic",
+ SvAMAGIC(left)?
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
+ SVfARG(&PL_sv_no),
+ SvAMAGIC(right)?
+ ",\n\tright argument in overloaded package ":
+ (flags & AMGf_unary
+ ? ""
+ : ",\n\tright argument has no overloaded magic"),
+ SvAMAGIC(right)?
+ SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
+ SVfARG(&PL_sv_no)));
if (use_default_op) {
- DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
+ DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
}
#ifdef DEBUGGING
if (!notfound) {
DEBUG_o(Perl_deb(aTHX_
- "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+ "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
AMG_id2name(off),
method+assignshift==off? "" :
" (initially \"",
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
flags & AMGf_unary? " for argument" : "",
- stash ? HvNAME_get(stash) : "null",
+ stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
fl? ",\n\tassignment variant used": "") );
}
#endif
/* off is method, method+assignshift, or a result of opcode substitution.
* In the latter case assignshift==0, so only notfound case is important.
*/
- if (( (method + assignshift == off)
+ if ( (lr == -1) && ( ( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
- || force_cpy)
+ || force_cpy) )
{
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
}
PERL_HASH(hash, name, len);
- GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -len : len), hash);
+ GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff