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))
+ ? (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;
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
- gv_name_set(gv, name, len, GV_ADD);
- if (multi || doproto) /* doproto means it _was_ mentioned */
- GvMULTI_on(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 (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));
}
}
}
{
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);
}
/*
+=for apidoc gv_fetchmeth
+
+Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
+
=for apidoc gv_fetchmeth_sv
Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
I32 items;
STRLEN packlen;
U32 topgen_cmp;
+ U32 is_utf8 = flags & SVf_UTF8;
PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
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(topgv, stash, name, len, TRUE);
+ 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) {
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);
else candidate = *gvp;
have_candidate:
assert(candidate);
- if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
+ if (SvTYPE(candidate) != SVt_PVGV)
+ 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:
/*
=for apidoc gv_fetchmeth_autoload
-Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
+parameter.
+
+=for apidoc gv_fetchmeth_sv_autoload
+
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pv_autoload
+
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
+ return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pvn_autoload
+
+Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
Returns a glob for the subroutine.
For an autoloaded subroutine without a GV, will create a GV even
if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
of the result may be zero.
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
=cut
*/
GV *
-Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+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_AUTOLOAD;
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
if (!gv) {
CV *cv;
return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
return NULL;
- if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
+ if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
return NULL;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return NULL;
/* Have an autoload */
if (level < 0) /* Cannot do without a stub */
- gv_fetchmeth_pvn(stash, name, len, 0, 0);
- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+ gv_fetchmeth_pvn(stash, name, len, 0, flags);
+ gvp = (GV**)hv_fetch(stash, name,
+ (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
if (!gvp)
return NULL;
return *gvp;
*/
STATIC HV*
-S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
+S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
{
AV* superisa;
GV** 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(gv, stash, "ISA", 3, TRUE);
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));
return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
}
+GV *
+Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
+}
+
+GV *
+Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
+ return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
+}
+
/* Don't merge this yet, as it's likely to get a len parameter, and possibly
even a U32 hash */
GV *
-Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
+Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
dVAR;
register const char *nend;
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_FLAGS;
+ PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
if (SvTYPE(stash) < SVt_PVHV)
stash = NULL;
the error reporting code. */
}
- for (nend = name; *nend; nend++) {
+ for (nend = name; *nend || nend != (origname + len); nend++) {
if (*nend == '\'') {
nsplit = nend;
name = nend + 1;
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));
+ stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME_get(stash), name) );
}
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))
- stash = gv_get_super_pkg(origname, nsplit - origname);
+ 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;
}
}
GV*
-Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
+Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ return gv_autoload_pvn(stash, namepv, namelen, flags);
+}
+
+GV*
+Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
+ return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
+}
+
+GV*
+Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
{
dVAR;
GV* gv;
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_AUTOLOAD4;
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
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);
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
- if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
+ 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 %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(vargv, varstash, S_autoload, S_autolen, FALSE);
+ 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));
}
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
const I32 no_expand = flags & GV_NOEXPAND;
const I32 add = flags & ~GV_NOADD_MASK;
+ const U32 is_utf8 = flags & SVf_UTF8;
bool addmg = !!(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
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(gv, stash, key, len, (add & GV_ADDMULTI));
+ 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) && *name == '[')
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
}
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(gv, stash, name, len, add & GV_ADDMULTI);
+ 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 */
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
+ case '[': /* $[ */
+ if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+ && FEATURE_IS_ENABLED_d("$[")) {
+ 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 '=': /* $= */
Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
const char *name;
- STRLEN namelen;
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);
- if (name) {
- namelen = HvNAMELEN_get(hv);
- } else {
- name = "__ANON__";
- namelen = 8;
- }
-
- if (keepmain || strNE(name, "main")) {
- sv_catpvn(sv,name,namelen);
+ 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,"::");
+ }
}
- sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+ else sv_catpvs(sv,"__ANON__::");
+ sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
}
void
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)));
}
}
}
}
GV *
-Perl_newGVgen(pTHX_ const char *pack)
+Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
{
dVAR;
+ PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
- PERL_ARGS_ASSERT_NEWGVGEN;
-
- return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
- GV_ADD, SVt_PVGV);
+ return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
+ SVfARG(newSVpvn_flags(pack, strlen(pack),
+ SVs_TEMP | flags)),
+ (long)PL_gensym++),
+ GV_ADD, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
/* 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);
But if B overloads "bool", we may want to use it for
numifying instead of C's "+0". */
if (i >= DESTROY_amg)
- gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
+ gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
else /* Autoload taken care of below */
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
"\" for overloaded \"%s\" in package \"%.256s\"\n",
(void*)GvSV(gv), cp, HvNAME(stash)) );
if (!gvsv || !SvPOK(gvsv)
- || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
- FALSE)))
+ || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
{
/* Can be an import stub (created by "can"). */
if (destructing) {
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);
+ 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);
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 */
U32 hash;
PERL_ARGS_ASSERT_GV_NAME_SET;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
}
PERL_HASH(hash, name, len);
- GvNAME_HEK(gv) = share_hek(name, len, hash);
+ GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff