view release on metacpan or  search on metacpan

lib/Devel/CallParser.xs  view on Meta::CPAN

		if(SvMAGICAL((SV*)cv))
			sv_unmagicext((SV*)cv, PERL_MAGIC_ext,
				&mgvtbl_parsecall);
	} else {
		MAGIC *callmg =
			mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_parsecall);
		if(!callmg)
			callmg = sv_magicext((SV*)cv, &PL_sv_undef,
				PERL_MAGIC_ext, &mgvtbl_parsecall, NULL, 0);
		if(callmg->mg_flags & MGf_REFCOUNTED) {
			SvREFCNT_dec(callmg->mg_obj);
			callmg->mg_flags &= ~MGf_REFCOUNTED;
		}
		callmg->mg_ptr = FPTR2DPTR(char *, psfun);
		callmg->mg_obj = psobj;
		if(psobj != (SV*)cv) {
			SvREFCNT_inc(psobj);
			callmg->mg_flags |= MGf_REFCOUNTED;
		}
	}
}

#if Q_PARSER_AVAILABLE

MY_EXPORT_CALLCONV void QPFXD(gcp1)(pTHX_ CV *cv,
	Perl_call_parser *psfun_p, SV **psobj_p)
{
	QPFXD(gcp0)(aTHX_ cv, psfun_p, psobj_p);
	if(!*psfun_p && !*psobj_p) {
		*psfun_p = Perl_parse_args_proto_or_list;
		*psobj_p = (SV*)cv;
	}
}

MY_EXPORT_CALLCONV void QPFXD(scp1)(pTHX_ CV *cv,
	Perl_call_parser psfun, SV *psobj)
{
	if(!psobj) croak("null object for cv_set_call_parser");
	QPFXD(scp0)(aTHX_ cv, psfun, psobj);
}

#endif /* Q_PARSER_AVAILABLE */

static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
static int my_keyword_plugin(pTHX_
	char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
{
	OP *nmop, *cvop, *argsop;
	CV *cv;
	GV *namegv;
	Perl_call_parser psfun;
	SV *psobj;
	U32 parser_flags;
	/*
	 * Creation of the rv2cv op below (or more precisely its gv op
	 * child created during checking) uses a pad slot under threads.
	 * Normally this is fine, but early versions of the padrange
	 * mechanism make assumptions about pad slots being contiguous
	 * that this breaks.  On the affected perl versions, therefore,
	 * we watch for the pad slot being consumed, and restore the
	 * pad's fill pointer if we throw the op away (upon declining
	 * to handle the keyword).
	 *
	 * The core bug was supposedly fixed in Perl 5.19.4, but actually
	 * that version exhibits a different bug also apparently related
	 * to padrange.  Restoring the pad's fill pointer works around
	 * this bug too.
	 *
	 * The other padrange bug was fixed in Perl 5.19.5 (commit aa033da),
	 * so the workaround is no longer needed after that, but it remains
	 * harmless until v5.21.4 (commit c9859fb)  where it starts breaking
	 * (see t/pad2.t.)	 */
#define MUST_RESTORE_PAD_FILL USE_THREADS && PERL_VERSION_GE(5,17,6) && ! PERL_VERSION_GE(5,19,5)
#if MUST_RESTORE_PAD_FILL
	I32 padfill = av_len(PL_comppad);
#endif /* MUST_RESTORE_PAD_FILL */
	/*
	 * If Devel::Declare happens to be loaded, it triggers magic
	 * upon building of an rv2cv op, assuming that it's being built
	 * by the lexer.  Since we're about to build such an op here,
	 * replicating what the lexer will normally do shortly after,
	 * there's a risk that Devel::Declare could fire here, ultimately
	 * firing twice for a single appearance of a name it's interested
	 * in.	To suppress Devel::Declare, therefore, we temporarily
	 * set PL_parser to null.  The same goes for Data::Alias and
	 * some other modules that use similar techniques.
	 *
	 * Unfortunately Devel::Declare prior to 0.006004 still does some
	 * work at the wrong time if PL_parser is null, and Data::Alias
	 * prior to 1.13 crashes if PL_parser is null.	So this module
	 * is not compatible with earlier versions of those modules,
	 * and can't be made compatible.
	 */
	ENTER;
	SAVEVPTR(PL_parser);
	PL_parser = NULL;
	nmop = newSVOP(OP_CONST, 0, newSVpvn(keyword_ptr, keyword_len));
	nmop->op_private = OPpCONST_BARE;
	cvop = newCVREF(0, nmop);
	LEAVE;
	if(!(cv = rv2cv_op_cv(cvop, 0))) {
		decline:
		op_free(cvop);
#if MUST_RESTORE_PAD_FILL
		av_fill(PL_comppad, padfill);
#endif /* MUST_RESTORE_PAD_FILL */
		return next_keyword_plugin(aTHX_
			keyword_ptr, keyword_len, op_ptr);
	}
	QPFXD(gcp0)(aTHX_ cv, &psfun, &psobj);
	if(!psfun && !psobj) goto decline;
	namegv = (GV*)rv2cv_op_cv(cvop,
			RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV);
	parser_flags = 0;
	argsop = psfun(aTHX_ namegv, psobj, &parser_flags);
	if(!(parser_flags & CALLPARSER_PARENS))
		cvop->op_private |= OPpENTERSUB_NOPAREN;
	*op_ptr = newUNOP(OP_ENTERSUB, OPf_STACKED,
			op_append_elem(OP_LIST, argsop, cvop));
	return (parser_flags & CALLPARSER_STATEMENT) ?
		KEYWORD_PLUGIN_STMT : KEYWORD_PLUGIN_EXPR;