#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);
}
if (!*where)
*where = newSV_type(type);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
return gv;
}
{
GP *gp;
U32 hash;
-#ifdef USE_ITHREADS
- const char *const file
- = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
- const STRLEN len = strlen(file);
-#else
- SV *const temp_sv = CopFILESV(PL_curcop);
const char *file;
STRLEN len;
+#ifndef USE_ITHREADS
+ SV * temp_sv;
+#endif
PERL_ARGS_ASSERT_NEWGP;
+ Newxz(gp, 1, GP);
+ gp->gp_egv = gv; /* allow compiler to reuse gv after this */
+#ifndef PERL_DONT_CREATE_GVSV
+ gp->gp_sv = newSV(0);
+#endif
+#ifdef USE_ITHREADS
+ if (PL_curcop) {
+ gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+ if (CopFILE(PL_curcop)) {
+ file = CopFILE(PL_curcop);
+ len = strlen(file);
+ }
+ else goto no_file;
+ }
+ else {
+ no_file:
+ file = "";
+ len = 0;
+ }
+#else
+ if(PL_curcop)
+ gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
+ temp_sv = CopFILESV(PL_curcop);
if (temp_sv) {
file = SvPVX(temp_sv);
len = SvCUR(temp_sv);
#endif
PERL_HASH(hash, file, len);
-
- Newxz(gp, 1, GP);
-
-#ifndef PERL_DONT_CREATE_GVSV
- gp->gp_sv = newSV(0);
-#endif
-
- gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
- /* XXX Ideally this cast would be replaced with a change to const char*
- in the struct. */
gp->gp_file_hek = share_hek(file, len, hash);
- gp->gp_egv = gv;
gp->gp_refcnt = 1;
return gp;
Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
{
GV * const oldgv = CvGV(cv);
+ HEK *hek;
PERL_ARGS_ASSERT_CVGV_SET;
if (oldgv == gv)
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
}
}
+ else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
- SvANY(cv)->xcv_gv = gv;
+ SvANY(cv)->xcv_gv_u.xcv_gv = gv;
assert(!CvCVGV_RC(cv));
if (!gv)
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;
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);
- if (doproto) { /* Replicate part of newSUB here. */
+ 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) {
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 (exported_constant)
GvIMPORTED_CV_on(gv);
+ CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
} else {
- (void) start_subparse(0,0); /* Create empty CV in compcv. */
- cv = PL_compcv;
- GvCV_set(gv,cv);
+ cv = newSTUB(gv,1);
}
- LEAVE;
-
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV_set(cv, gv);
- CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH_set(cv, PL_curstash);
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) {
+ if (!code) return NULL; /* Not a keyword */
+ switch (code < 0 ? -code : code) {
/* no support for \&CORE::infix;
- no support for funcs that take labels, as their parsing is
- weird */
- case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
- case KEY_eq: case KEY_ge:
- case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
- case KEY_or: case KEY_x: case KEY_xor:
+ no support for funcs that do not parse like funcs */
+ case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
+ case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
+ case KEY_default : case KEY_DESTROY:
+ case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
+ case KEY_END : case KEY_eq : case KEY_eval :
+ case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
+ case KEY_given : case KEY_goto : case KEY_grep :
+ case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
+ case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
+ case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
+ case KEY_package: case KEY_print: case KEY_printf:
+ case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
+ case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
+ case KEY_s : case KEY_say : case KEY_sort :
+ case KEY_state: case KEY_sub :
+ case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
+ case KEY_until: case KEY_use : case KEY_when : case KEY_while :
+ case KEY_x : case KEY_xor : case KEY_y :
return NULL;
case KEY_chdir:
- case KEY_chomp: case KEY_chop:
- case KEY_each: case KEY_eof: case KEY_exec:
+ case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
+ case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
case KEY_keys:
case KEY_lstat:
case KEY_pop:
case KEY_push:
case KEY_shift:
- case KEY_splice:
+ case KEY_splice: case KEY_split:
case KEY_stat:
case KEY_system:
case KEY_truncate: case KEY_unlink:
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)
+ if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+ && opnum != OP_UNDEF)
CvLVALUE_off(cv); /* Now *that* was a neat trick. */
LEAVE;
PL_parser = oldparser;
which in the case of success contains an alias for the subroutine, and sets
up caching info for this glob.
-Currently, the only significant value for C<flags> is SVf_UTF8.
+The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
-This function grants C<"SUPER"> token as a postfix of the stash name. The
+GV_SUPER indicates that we want to look up the method in the superclasses
+of the C<stash>.
+
+The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
visible to Perl code. So when calling C<call_sv>, you should not use
the GV directly; instead, you should use the method's CV, which can be
AV* linear_av;
SV** linear_svp;
SV* linear_sv;
- HV* cstash;
+ HV* cstash, *cachestash;
GV* candidate = NULL;
CV* cand_cv = NULL;
GV* topgv = NULL;
const char *hvname;
I32 create = (level >= 0) ? 1 : 0;
I32 items;
- STRLEN packlen;
U32 topgen_cmp;
+ U32 is_utf8 = flags & SVf_UTF8;
PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
assert(hvname);
assert(name);
- DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
+ DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
+ flags & GV_SUPER ? "SUPER " : "",name,hvname) );
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
+ if (flags & GV_SUPER) {
+ if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
+ cachestash = HvAUX(stash)->xhv_super;
+ }
+ else cachestash = stash;
+
/* check locally for a real method or a cache entry */
- gvp = (GV**)hv_fetch(stash, name, len, create);
+ gvp = (GV**)hv_fetch(cachestash, 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) {
/* cache indicates no such method definitively */
return 0;
}
- else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
+ else if (stash == cachestash
+ && 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;
}
- packlen = HvNAMELEN_get(stash);
- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
- HV* basestash;
- packlen -= 7;
- basestash = gv_stashpvn(hvname, packlen, GV_ADD);
- linear_av = mro_get_linear_isa(basestash);
- }
- else {
- linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
- }
-
+ linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
items = AvFILLp(linear_av); /* no +1, to skip over self */
while (items--) {
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;
}
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:
/* Check UNIVERSAL without caching */
if(level == 0 || level == -1) {
- candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
+ candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
if(candidate) {
cand_cv = GvCV(candidate);
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
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;
=cut
*/
-STATIC HV*
-S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
-{
- AV* superisa;
- GV** gvp;
- GV* gv;
- HV* stash;
-
- PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
-
- stash = gv_stashpvn(name, namelen, 0);
- 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);
- gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
- gv = *gvp;
- 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));
-#else
- av_push(superisa, newSVhek(CopSTASH(PL_curcop)
- ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
-
- return stash;
-}
-
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
dVAR;
- register const char *nend;
+ const char *nend;
const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
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)));
- /* __PACKAGE__::SUPER stash should be autovivified */
- stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
+ stash = CopSTASH(PL_curcop);
+ flags |= GV_SUPER;
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
- origname, HvNAME_get(stash), name) );
+ origname, HvENAME_get(stash), name) );
+ }
+ else if ((nsplit - origname) >= 7 &&
+ strnEQ(nsplit - 7, "::SUPER", 7)) {
+ /* don't autovifify if ->NoSuchStash::SUPER::method */
+ stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+ if (stash) flags |= GV_SUPER;
}
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, nsplit - origname, 0);
-
- /* 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);
+ stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
}
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_sv(pTHX_ HV *stash, SV* namesv, I32 method, U32 flags)
+Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
{
char *namepv;
STRLEN namelen;
- PERL_ARGS_ASSERT_GV_AUTOLOAD4_SV;
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
namepv = SvPV(namesv, namelen);
if (SvUTF8(namesv))
flags |= SVf_UTF8;
- return gv_autoload4_pvn(stash, namepv, namelen, method, flags);
+ return gv_autoload_pvn(stash, namepv, namelen, flags);
}
GV*
-Perl_gv_autoload4_pv(pTHX_ HV *stash, const char *namepv, I32 method, U32 flags)
+Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
{
- PERL_ARGS_ASSERT_GV_AUTOLOAD4_PV;
- return gv_autoload4_pvn(stash, namepv, strlen(namepv), method, flags);
+ PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
+ return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
}
GV*
-Perl_gv_autoload4_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 method, U32 flags)
+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_PVN;
+ 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 (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
}
- 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);
+ SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+ /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
+ 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;
+ SAVEFREESV(namesv);
if ( flags & 1 )
save_scalar(gv);
PUSHSTACKi(PERLSI_MAGIC);
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
POPSTACK;
- LEAVE;
- 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);
+ LEAVE;
}
- SvREFCNT_dec(namesv);
+ else SvREFCNT_dec(namesv);
return stash;
}
C<flags> is 0 (or any other setting that does not create packages) then NULL
is returned.
+Flags may be one of:
+
+ GV_ADD
+ SVf_UTF8
+ GV_NOADD_NOINIT
+ GV_NOINIT
+ GV_NOEXPAND
+ GV_ADDMG
+
+The most important of which are probably GV_ADD and SVf_UTF8.
=cut
*/
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));
}
NULL, 0);
}
-STATIC void
-S_gv_magicalize_overload(pTHX_ GV *gv)
-{
- HV* hv;
-
- PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
-
- hv = GvHVn(gv);
- GvMULTI_on(gv);
- hv_magic(hv, NULL, PERL_MAGIC_overload);
-}
-
GV *
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype sv_type)
{
dVAR;
- register const char *name = nambeg;
- register GV *gv = NULL;
+ const char *name = nambeg;
+ GV *gv = NULL;
GV**gvp;
I32 len;
- register const char *name_cursor;
+ const char *name_cursor;
HV *stash = NULL;
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) {
+ switch (*name) {
+ case '[':
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ break;
+ case '`':
+ PL_sawampersand |= SAWAMPERSAND_LEFT;
+ (void)GvSVn(gv);
+ break;
+ case '&':
+ PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+ (void)GvSVn(gv);
+ break;
+ case '\'':
+ PL_sawampersand |= SAWAMPERSAND_RIGHT;
+ (void)GvSVn(gv);
+ break;
+ }
+ }
}
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 */
if (stash != PL_defstash) { /* not the main stash */
- /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
+ /* We only have to check for three names here: EXPORT, ISA
and VERSION. All the others apply only to the main stash or to
CORE (which is checked right after this). */
if (len > 2) {
if (strEQ(name2, "SA"))
gv_magicalize_isa(gv);
break;
- case 'O':
- if (strEQ(name2, "VERLOAD"))
- gv_magicalize_overload(gv);
- break;
case 'V':
if (strEQ(name2, "ERSION"))
GvMULTI_on(gv);
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) {
gv_magicalize_isa(gv);
}
break;
- case 'O':
- if (strEQ(name2, "VERLOAD")) {
- gv_magicalize_overload(gv);
- }
- break;
case 'S':
if (strEQ(name2, "IG")) {
HV *hv;
if (strEQ(name2, "LOBAL_PHASE"))
goto ro_magicalize;
break;
+ case '\014': /* $^LAST_FH */
+ if (strEQ(name2, "AST_FH"))
+ goto ro_magicalize;
+ break;
case '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto magicalize;
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 |=
+ (*name == '`')
+ ? SAWAMPERSAND_LEFT
+ : (*name == '&')
+ ? SAWAMPERSAND_MIDDLE
+ : SAWAMPERSAND_RIGHT;
+ }
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;
- case '|': /* $| */
- sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
- goto magicalize;
-
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) {
+ 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 '=': /* $= */
case '>': /* $> */
case '\\': /* $\ */
case '/': /* $/ */
+ case '|': /* $| */
case '$': /* $$ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\014': /* $^L */
sv_setpvs(GvSVn(gv),"\f");
- PL_formfeed = GvSVn(gv);
break;
case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
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
Perl_gv_check(pTHX_ const HV *stash)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- register GV *gv;
+ GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(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)));
}
}
}
}
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);
+ DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
+ 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);
newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
if (mg) {
const AMT * const amtp = (AMT*)mg->mg_ptr;
- if (amtp->was_ok_am == PL_amagic_generation
- && amtp->was_ok_sub == newgen) {
- return AMT_OVERLOADED(amtp) ? 1 : 0;
+ if (amtp->was_ok_sub == newgen) {
+ return AMT_AMAGIC(amtp) ? 1 : 0;
}
sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
}
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
Zero(&amt,1,AMT);
- amt.was_ok_am = PL_amagic_generation;
amt.was_ok_sub = newgen;
amt.fallback = AMGfallNO;
amt.flags = 0;
{
- int filled = 0, have_ovl = 0;
- int i, lim = 1;
+ int filled = 0;
+ int i;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
CV* cv;
if (!gv)
- lim = DESTROY_amg; /* Skip overloading entries. */
+ {
+ if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
+ goto no_table;
+ }
#ifdef PERL_DONT_CREATE_GVSV
else if (!sv) {
NOOP; /* Equivalent to !SvTRUE and !SvOK */
}
#endif
else if (SvTRUE(sv))
+ /* don't need to set overloading here because fallback => 1
+ * is the default setting for classes without overloading */
amt.fallback=AMGfallYES;
- else if (SvOK(sv))
+ else if (SvOK(sv)) {
amt.fallback=AMGfallNEVER;
+ filled = 1;
+ }
+ else {
+ filled = 1;
+ }
- for (i = 1; i < lim; i++)
- amt.table[i] = NULL;
- for (; i < NofAMmeth; i++) {
+ for (i = 1; i < NofAMmeth; i++) {
const char * const cooky = PL_AMG_names[i];
/* Human-readable form, for debugging: */
- const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+ const char * const cp = AMG_id2name(i);
const STRLEN l = PL_AMG_namelens[i];
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
then we could have created stubs for "(+0" in A and C too.
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_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);
+ gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
if (gv && (cv = GvCV(gv))) {
if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
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);
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
GvNAME(CvGV(cv))) );
filled = 1;
- if (i < DESTROY_amg)
- have_ovl = 1;
} else if (gv) { /* Autoloaded... */
cv = MUTABLE_CV(gv);
filled = 1;
}
if (filled) {
AMT_AMAGIC_on(&amt);
- if (have_ovl)
- AMT_OVERLOADED_on(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMT));
- return have_ovl;
+ return TRUE;
}
}
/* Here we have no table: */
- /* no_table: */
+ no_table:
AMT_AMAGIC_off(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
(char*)&amt, sizeof(AMTS));
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
if (!mg) {
do_update:
- /* If we're looking up a destructor to invoke, we must avoid
- * that Gv_AMupdate croaks, because we might be dying already */
- if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
- /* and if it didn't found a destructor, we fall back
- * to a simpler method that will only look for the
- * destructor instead of the whole magic */
- if (id == DESTROY_amg) {
- GV * const gv = gv_fetchmethod(stash, "DESTROY");
- if (gv)
- return GvCV(gv);
- }
+ if (Gv_AMupdate(stash, 0) == -1)
return NULL;
- }
mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
}
assert(mg);
amtp = (AMT*)mg->mg_ptr;
- if ( amtp->was_ok_am != PL_amagic_generation
- || amtp->was_ok_sub != newgen )
+ if ( amtp->was_ok_sub != newgen )
goto do_update;
if (AMT_AMAGIC(amtp)) {
CV * const ret = amtp->table[id];
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)
{
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
int use_default_op = 0;
+ int force_scalar = 0;
#ifdef DEBUGGING
int fl=0;
#endif
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)
- && (stash = SvSTASH(SvRV(left)))
+ && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
*/
SV* const newref = newSVsv(tmpRef);
SvOBJECT_on(newref);
- /* As a bit of a source compatibility hack, SvAMAGIC() and
- friends dereference an RV, to behave the same was as when
- overloading was stored on the reference, not the referant.
- Hence we can't use SvAMAGIC_on()
- */
- SvFLAGS(newref) |= SVf_AMAGIC;
+ /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
+ delegate to the stash. */
SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
return newref;
}
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
- && (stash = SvSTASH(SvRV(right)))
+ && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
&& (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: NULL))
- && (cv = cvp[off=method])) { /* Method for right
- * argument found */
- lr=1;
+ && ((cv = cvp[off=method+assignshift])
+ || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+ * usual method */
+ (
+#ifdef DEBUGGING
+ fl = 1,
+#endif
+ cv = cvp[off=method])))) { /* Method for right
+ * argument found */
+ lr=1;
} else if (((cvp && amtp->fallback > AMGfallNEVER)
|| (ocvp && oamtp->fallback > AMGfallNEVER))
&& !(flags & AMGf_unary)) {
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));
}
force_cpy = force_cpy || assign;
}
}
+
+ switch (method) {
+ /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
+ * operation. we need this to return a value, so that it can be assigned
+ * later on, in the postpr block (case inc_amg/dec_amg), even if the
+ * increment or decrement was itself called in void context */
+ case inc_amg:
+ if (off == add_amg)
+ force_scalar = 1;
+ break;
+ case dec_amg:
+ if (off == subtr_amg)
+ force_scalar = 1;
+ break;
+ /* in these cases, we're calling an assignment variant of an operator
+ * (+= rather than +, for instance). regardless of whether it's a
+ * fallback or not, it always has to return a value, which will be
+ * assigned to the proper variable later */
+ case add_amg:
+ case subtr_amg:
+ case mult_amg:
+ case div_amg:
+ case modulo_amg:
+ case pow_amg:
+ case lshift_amg:
+ case rshift_amg:
+ case repeat_amg:
+ case concat_amg:
+ case band_amg:
+ case bor_amg:
+ case bxor_amg:
+ if (assign)
+ force_scalar = 1;
+ break;
+ /* the copy constructor always needs to return a value */
+ case copy_amg:
+ force_scalar = 1;
+ break;
+ /* because of the way these are implemented (they don't perform the
+ * dereferencing themselves, they return a reference that perl then
+ * dereferences later), they always have to be in scalar context */
+ case to_sv_amg:
+ case to_av_amg:
+ case to_hv_amg:
+ case to_gv_amg:
+ case to_cv_amg:
+ force_scalar = 1;
+ break;
+ /* these don't have an op of their own; they're triggered by their parent
+ * op, so the context there isn't meaningful ('$a and foo()' in void
+ * context still needs to pass scalar context on to $a's bool overload) */
+ case bool__amg:
+ case numer_amg:
+ case string_amg:
+ force_scalar = 1;
+ break;
+ }
+
#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 */
BINOP myop;
SV* res;
const bool oldcatch = CATCH_GET;
+ I32 oldmark, nret;
+ int gimme = force_scalar ? G_SCALAR : GIMME_V;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = NULL;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ myop.op_flags = OPf_STACKED;
+
+ switch (gimme) {
+ case G_VOID:
+ myop.op_flags |= OPf_WANT_VOID;
+ break;
+ case G_ARRAY:
+ if (flags & AMGf_want_list) {
+ myop.op_flags |= OPf_WANT_LIST;
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ myop.op_flags |= OPf_WANT_SCALAR;
+ break;
+ }
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER;
}
PUSHs(MUTABLE_SV(cv));
PUTBACK;
+ oldmark = TOPMARK;
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
CALLRUNOPS(aTHX);
LEAVE;
SPAGAIN;
+ nret = SP - (PL_stack_base + oldmark);
+
+ switch (gimme) {
+ case G_VOID:
+ /* returning NULL has another meaning, and we check the context
+ * at the call site too, so this can be differentiated from the
+ * scalar case */
+ res = &PL_sv_undef;
+ SP = PL_stack_base + oldmark;
+ break;
+ case G_ARRAY: {
+ if (flags & AMGf_want_list) {
+ res = sv_2mortal((SV *)newAV());
+ av_extend((AV *)res, nret);
+ while (nret--)
+ av_store((AV *)res, nret, POPs);
+ break;
+ }
+ /* FALLTHROUGH */
+ }
+ default:
+ res = POPs;
+ break;
+ }
- res=POPs;
PUTBACK;
POPSTACK;
CATCH_SET(oldcatch);
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);
}
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff