view release on metacpan or  search on metacpan

lib/Array/Base.xs  view on Meta::CPAN

#endif /* OPpGREP_LEX */
	return mop;
}

static OP *THX_myck_aelem(pTHX_ OP *op)
{
	IV base;
	if((base = current_base()) != 0) {
		OP *aop, *iop;
		if(!(op->op_flags & OPf_KIDS)) {
			bad_ops:
			croak("strange op tree prevents applying array base");
		}
		aop = cBINOPx(op)->op_first;
		iop = OpSIBLING(aop);
		if(!iop || OpHAS_SIBLING(iop)) goto bad_ops;
		OpLASTSIB_set(aop, op);
		cBINOPx(op)->op_last = NULL;
		OpLASTSIB_set(iop, NULL);
		iop = op_contextualize(
				newBINOP(OP_I_SUBTRACT, 0, iop,
					newSVOP(OP_CONST, 0, newSViv(base))),
				G_SCALAR);
		OpMORESIB_set(aop, iop);
		OpLASTSIB_set(iop, op);
		cBINOPx(op)->op_last = iop;
	}
	return THX_nxck_aelem(aTHX_ op);
}

static OP *THX_myck_aslice(pTHX_ OP *op)
{
	IV base;
	if((base = current_base()) != 0) {
		OP *iop, *aop;
		if(!(op->op_flags & OPf_KIDS)) {
			bad_ops:
			croak("strange op tree prevents applying array base");
		}
		iop = cLISTOPx(op)->op_first;
		aop = OpSIBLING(iop);
		if(!aop || OpHAS_SIBLING(aop)) goto bad_ops;
		OpLASTSIB_set(iop, NULL);
		cLISTOPx(op)->op_first = aop;
		iop = op_contextualize(mapify_op(iop, base, OP_I_SUBTRACT),
			G_ARRAY);
		OpMORESIB_set(iop, aop);
		cLISTOPx(op)->op_first = iop;
	}
	return THX_nxck_aslice(aTHX_ op);
}

#if QHAVE_OP_KVASLICE

static OP *THX_pp_munge_kvaslice(pTHX)
{
	dSP; dMARK;
	if(SP != MARK) {
		SV **kp;
		IV base = POPi;
		PUTBACK;
		if(MARK+1 != SP) {
			for(kp = MARK; kp != SP; kp += 2) {
				SV *k = kp[1];
				if(SvOK(k))
					kp[1] = sv_2mortal(
						newSViv(SvIV(k) + base));
			}
		}
	}
	return PL_op->op_next;
}

#define newUNOP_munge_kvaslice(f, l) THX_newUNOP_munge_kvaslice(aTHX_ f, l)
static OP *THX_newUNOP_munge_kvaslice(pTHX_ OP *kvasliceop, OP *baseop)
{
	OP *mungeop, *pushop;
	pushop = newOP(OP_PUSHMARK, 0);
	NewOpSz(0, mungeop, sizeof(UNOP));
#ifdef XopENTRY_set
	mungeop->op_type = OP_CUSTOM;
#else /* !XopENTRY_set */
	mungeop->op_type = OP_DOFILE;
#endif /* !XopENTRY_set */
	mungeop->op_ppaddr = THX_pp_munge_kvaslice;
	mungeop->op_flags = OPf_KIDS;
	cUNOPx(mungeop)->op_first = pushop;
	OpMORESIB_set(pushop, kvasliceop);
	OpMORESIB_set(kvasliceop, baseop);
	OpLASTSIB_set(baseop, mungeop);
	return mungeop;
}

static OP *THX_myck_kvaslice(pTHX_ OP *op)
{
	IV base;
	if((base = current_base()) != 0) {
		OP *iop, *aop;
		if(!(op->op_flags & OPf_KIDS)) {
			bad_ops:
			croak("strange op tree prevents applying array base");
		}
		iop = cLISTOPx(op)->op_first;
		aop = OpSIBLING(iop);
		if(!aop || OpHAS_SIBLING(aop)) goto bad_ops;
		/*
		 * A kvaslice op is built in a nasty way that interferes
		 * with munging it through a checker.  It's first built
		 * containing the interesting operands, but missing a
		 * necessary pushmark op.  The checker gets invoked on
		 * this incomplete op.	Then the pushmark gets inserted,
		 * without invoking any checker, provided that the op is
		 * still of type kvaslice.  If the checker changed the op
		 * type, then instead a new kvaslice gets built containing
		 * the pushmark and whatever the checker returned,
		 * and the checker gets invoked a second time on that.
		 *
		 * The incomplete structure the first time round
		 * means we can't very well wrap the op at that point.
		 * We can munge the operands, but the wrapping needs to
		 * be postponed until after the pushmark gets inserted.

lib/Array/Base.xs  view on Meta::CPAN

	if((base = current_base()) != 0) {
		OP *pop, *aop, *iop;
		if(!(op->op_flags & OPf_KIDS)) {
			bad_ops:
			croak("strange op tree prevents applying array base");
		}
		pop = cLISTOPx(op)->op_first;
		if(pop->op_type != OP_PUSHMARK) goto bad_ops;
		aop = OpSIBLING(pop);
		if(!aop) goto bad_ops;
		iop = OpSIBLING(aop);
		if(iop) {
			OP *rest = OpSIBLING(iop);
			OpMAYBESIB_set(aop, rest, op);
			OpLASTSIB_set(iop, NULL);
			if(!rest) cLISTOPx(op)->op_last = aop;
			iop = newBINOP(OP_I_SUBTRACT, 0,
					op_contextualize(iop, G_SCALAR),
					newSVOP(OP_CONST, 0, newSViv(base)));
			OpMAYBESIB_set(iop, rest, op);
			OpMORESIB_set(aop, iop);
			if(!rest) cLISTOPx(op)->op_last = iop;
		}
	}
	return THX_nxck_splice(aTHX_ op);
}

#if QHAVE_OP_AKEYS
static OP *THX_myck_keys(pTHX_ OP *op)
{
	/*
	 * Annoyingly, keys(@array) ops don't go through the nominal
	 * checker for OP_AKEYS.  Instead they start out as OP_KEYS,
	 * and get mutated to OP_AKEYS by the OP_KEYS checker.  This
	 * is therefore what we have to hook.
	 */
	OP *aop;
	IV base;
	if((op->op_flags & OPf_KIDS) && (aop = cUNOPx(op)->op_first, 1) &&
			(aop->op_type == OP_PADAV ||
			 aop->op_type == OP_RV2AV) &&
			(base = current_base()) != 0) {
		return mapify_op(
			op_contextualize(THX_nxck_keys(aTHX_ op), G_ARRAY),
			base, OP_I_ADD);
	} else {
		return THX_nxck_keys(aTHX_ op);
	}
}
#endif /* QHAVE_OP_AKEYS */

#if QHAVE_OP_AEACH

static OP *THX_pp_munge_aeach(pTHX)
{
	dSP; dMARK;
	if(SP != MARK) {
		IV base = POPi;
		if(SP != MARK && SvOK(MARK[1]))
			MARK[1] = sv_2mortal(newSViv(SvIV(MARK[1]) + base));
		PUTBACK;
	}
	return PL_op->op_next;
}

#define newUNOP_munge_aeach(f, l) THX_newUNOP_munge_aeach(aTHX_ f, l)
static OP *THX_newUNOP_munge_aeach(pTHX_ OP *aeachop, OP *baseop)
{
	OP *mungeop, *pushop;
	pushop = newOP(OP_PUSHMARK, 0);
	NewOpSz(0, mungeop, sizeof(UNOP));
#ifdef XopENTRY_set
	mungeop->op_type = OP_CUSTOM;
#else /* !XopENTRY_set */
	mungeop->op_type = OP_DOFILE;
#endif /* !XopENTRY_set */
	mungeop->op_ppaddr = THX_pp_munge_aeach;
	mungeop->op_flags = OPf_KIDS;
	cUNOPx(mungeop)->op_first = pushop;
	OpMORESIB_set(pushop, aeachop);
	OpMORESIB_set(aeachop, baseop);
	OpLASTSIB_set(baseop, mungeop);
	return mungeop;
}

static OP *THX_myck_each(pTHX_ OP *op)
{
	/*
	 * Annoyingly, each(@array) ops don't go through the nominal
	 * checker for OP_AEACH.  Instead they start out as OP_EACH,
	 * and get mutated to OP_AEACH by the OP_EACH checker.  This
	 * is therefore what we have to hook.
	 */
	OP *aop;
	IV base;
	if((op->op_flags & OPf_KIDS) && (aop = cUNOPx(op)->op_first, 1) &&
			(aop->op_type == OP_PADAV ||
			 aop->op_type == OP_RV2AV) &&
			(base = current_base()) != 0) {
		return newUNOP_munge_aeach(THX_nxck_each(aTHX_ op),
					newSVOP(OP_CONST, 0, newSViv(base)));
	} else {
		return THX_nxck_each(aTHX_ op);
	}
}

#endif /* QHAVE_OP_AEACH */

MODULE = Array::Base PACKAGE = Array::Base

PROTOTYPES: DISABLE

BOOT:
{
#ifdef XopENTRY_set
	XOP *xop;
	Newxz(xop, 1, XOP);
	XopENTRY_set(xop, xop_name, "munge_aeach");
	XopENTRY_set(xop, xop_desc, "fixup following each on array");
	XopENTRY_set(xop, xop_class, OA_UNOP);
	Perl_custom_op_register(aTHX_ THX_pp_munge_aeach, xop);