#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;
}
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
char * const proto = (doproto && SvPOK(gv))
- ? (SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0), SvPVX(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;
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) {
/* newCONSTSUB takes ownership of the reference from us. */
cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
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);
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;
}
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:
case '\014': /* $^L */
sv_setpvs(GvSVn(gv),"\f");
- PL_formfeed = GvSVn(gv);
+ PL_formfeed = GvSV(gv);
break;
case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
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 */
}
#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;
+ have_ovl = 1;
+ }
+ else {
+ filled = 1;
+ have_ovl = 1;
+ }
for (i = 1; i < lim; i++)
amt.table[i] = NULL;
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)
{
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)) {
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_
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);
* 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