#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
+ dVAR;
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)
if (oldgv) {
if (CvCVGV_RC(cv)) {
- SvREFCNT_dec(oldgv);
+ SvREFCNT_dec_NN(oldgv);
CvCVGV_RC_off(cv);
}
else {
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)
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;
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. */
+ 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_flags(stash, (name0 ? name0 : name), flags, 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.
+
+GV_SUPER indicates that we want to look up the method in the superclasses
+of the C<stash>.
-This function grants C<"SUPER"> token as a postfix of the stash name. The
+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;
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:
}
else {
/* stale cache entry, junk it and move on */
- SvREFCNT_dec(cand_cv);
+ SvREFCNT_dec_NN(cand_cv);
GvCV_set(topgv, NULL);
cand_cv = NULL;
GvCVGEN(topgv) = 0;
/* 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;
}
/* 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, U32 flags)
-{
- 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_pvn(gv, stash, "ISA", 3, GV_ADDMULTI|(flags & SVf_UTF8));
- 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), SvUTF8(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, flags);
+ 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);
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));
}
}
}
}
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, is_utf8)))
return NULL;
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
- SvPV_nolen(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);
- if (is_utf8)
+ if (SvPOK(cv)) { /* Ouch! */
+ SV * const 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_NN(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);
- return gv;
+ else SvUTF8_off(cv);
+ }
+ CvAUTOLOAD_on(cv);
}
/*
}
LEAVE;
varsv = GvSVn(vargv);
+ 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_NN(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
*/
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;
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++;
}
if (!stash) {
no_stash:
- if (len && isIDFIRST_lazy(name)) {
+ if (len && isIDFIRST_lazy_if(name, is_utf8)) {
bool global = FALSE;
switch (len) {
(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;
}
/* By this point we should have a stash and a name */
if (!stash) {
- if (add) {
+ if (add && !PL_in_clean_all) {
+ SV * const namesv = newSVpvn_flags(name, len, is_utf8);
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(namesv));
GV *gv;
+ SvREFCNT_dec_NN(namesv);
if (USE_UTF8_IN_NAMES)
SvUTF8_on(err);
qerror(err);
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;
+#ifdef PERL_SAWAMPERSAND
+ 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;
+#endif
+ }
+ }
}
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);
+ 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 (
+#ifdef PERL_SAWAMPERSAND
+ 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;
+ }
+#endif
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");
GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
))
(void)hv_store(stash,name,len,(SV *)gv,0);
- else SvREFCNT_dec(gv), gv = NULL;
+ else SvREFCNT_dec_NN(gv), gv = NULL;
}
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
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))));
}
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)));
}
}
}
/* If the GP they asked for a reference to contains
a method cache entry, clear it first, so that we
don't infect them with our cached entry */
- SvREFCNT_dec(gp->gp_cv);
+ SvREFCNT_dec_NN(gp->gp_cv);
gp->gp_cv = NULL;
gp->gp_cvgen = 0;
}
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
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)),
for (i = 1; i < NofAMmeth; i++) {
CV * const cv = amtp->table[i];
if (cv) {
- SvREFCNT_dec(MUTABLE_SV(cv));
+ SvREFCNT_dec_NN(MUTABLE_SV(cv));
amtp->table[i] = NULL;
}
}
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
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 */
if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
SvRV_set(left, rv_copy);
SvSETMAGIC(left);
- SvREFCNT_dec(tmpRef);
+ SvREFCNT_dec_NN(tmpRef);
}
}
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);
}
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);
}
/*
* 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