#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);
}
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;
GvMULTI_on(gv); /* _was_ mentioned */
if (doproto) { /* Replicate part of newSUB here. */
CV *cv;
- ENTER;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
if (exported_constant)
GvIMPORTED_CV_on(gv);
} else {
+ ENTER;
(void) start_subparse(0,0); /* Create empty CV in compcv. */
cv = PL_compcv;
GvCV_set(gv,cv);
+ LEAVE;
}
- 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);
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__;
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;
}
else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
&& strnEQ(hvname, "CORE", 4)
- && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
+ && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
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;
}
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, newSVpvn_flags(CopSTASHPV(PL_curcop),
- strlen(CopSTASHPV(PL_curcop)),
- CopSTASH_flags(PL_curcop)
- ));
-#else
av_push(superisa, newSVhek(CopSTASH(PL_curcop)
? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
return stash;
}
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
sv_catpvn_flags(
varsv, name, len,
- SV_GMAGIC|SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+ SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
);
if (is_utf8)
SvUTF8_on(varsv);
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
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)
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
- if ((sv_type==SVt_PV || sv_type==SVt_PVGV) && *name == '[')
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ if (*name == '[')
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ else if (*name == '&' || *name == '`' || *name == '\'') {
+ PL_sawampersand = TRUE;
+ (void)GvSVn(gv);
+ }
+ }
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
/* 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;
case '&': /* $& */
case '`': /* $` */
case '\'': /* $' */
- if (
+ if (!(
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
sv_type == SVt_PVCV ||
sv_type == SVt_PVFM ||
sv_type == SVt_PVIO
- ) { break; }
- PL_sawampersand = TRUE;
+ )) { PL_sawampersand = TRUE; }
goto magicalize;
case ':': /* $: */
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ }
break;
case '-': /* $- */
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ addmg = 0;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ }
break;
}
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"$%c is no longer supported", *name);
break;
}
goto magicalize;
case '[': /* $[ */
- if (sv_type == SVt_PV || sv_type == SVt_PVGV) {
+ 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:
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) {
+ if (amtp->was_ok_sub == newgen) {
return AMT_OVERLOADED(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;
CV* cv;
if (!gv)
+ {
+ if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
lim = DESTROY_amg; /* Skip overloading entries. */
+ }
#ifdef PERL_DONT_CREATE_GVSV
else if (!sv) {
NOOP; /* Equivalent to !SvTRUE and !SvOK */
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"\"",
}
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)
{
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)) {
/* 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 */
* 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