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);
assert(gv || stash);
assert(name);
- 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:
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;
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),
- CopSTASH_len(PL_curcop) < 0
- ? -CopSTASH_len(PL_curcop)
- : CopSTASH_len(PL_curcop),
- SVf_UTF8*(CopSTASH_len(PL_curcop) < 0)
- ));
-#else
av_push(superisa, newSVhek(CopSTASH(PL_curcop)
? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
return stash;
}
case '\014': /* $^L */
sv_setpvs(GvSVn(gv),"\f");
- PL_formfeed = GvSVn(gv);
+ PL_formfeed = GvSV(gv);
break;
case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
}
#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;
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
&& (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