view release on metacpan or  search on metacpan

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

	if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
		croak("panic: parse_args_proto with no proto");
	/*
	 * There are variations between Perl versions in the syntactic
	 * interpretation of prototypes, which this code in principle
	 * needs to track.  However, from the introduction of the parser
	 * API functions required by this code (5.13.8) to the date
	 * of this note (5.14.0-RC0) there have been no such changes.
	 * With luck there may be no more before this function migrates
	 * into the core.
	 */
	proto = SvPV(protosv, proto_len);
	if(!proto_len) return parse_args_nullary(flags_p);
	while(*proto == ';') proto++;
	if(proto[0] == '&') return parse_args_block_list(flags_p);
	if(((proto[0] == '$' || proto[0] == '_' ||
					proto[0] == '*' || proto[0] == '+') &&
				!proto[1]) ||
			(proto[0] == '\\' && proto[1] && !proto[2]))
		return parse_args_unary(flags_p);
	if(proto[0] == '\\' && proto[1] == '['/*]*/) {
		proto += 2;
		while(*proto && *proto != /*[*/']') proto++;
		if(proto[0] == /*[*/']' && !proto[1])
			return parse_args_unary(flags_p);
	}
	return parse_args_list(flags_p);
}

# define Perl_parse_args_proto_or_list QPFXD(pan0)
# define parse_args_proto_or_list(gv, sv, fp) \
	Perl_parse_args_proto_or_list(aTHX_ gv, sv, fp)
MY_EXPORT_CALLCONV OP *QPFXD(pan0)(pTHX_ GV *namegv, SV *protosv, U32 *flags_p)
{
	if(SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
		return parse_args_proto(namegv, protosv, flags_p);
	else
		return parse_args_list(flags_p);
}

#endif /* Q_PARSER_AVAILABLE */

#ifndef mg_findext
# define mg_findext(sv, type, vtbl) THX_mg_findext(aTHX_ sv, type, vtbl)
static MAGIC *THX_mg_findext(pTHX_ SV *sv, int type, MGVTBL const *vtbl)
{
	MAGIC *mg;
	if(sv)
		for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
			if(mg->mg_type == type && mg->mg_virtual == vtbl)
				return mg;
	return NULL;
}
#endif /* !mg_findext */

#ifndef sv_unmagicext
# define sv_unmagicext(sv, type, vtbl) THX_sv_unmagicext(aTHX_ sv, type, vtbl)
static int THX_sv_unmagicext(pTHX_ SV *sv, int type, MGVTBL const *vtbl)
{
	MAGIC *mg, **mgp;
	if((vtbl && vtbl->svt_free) || type == PERL_MAGIC_regex_global)
		/* exceeded intended usage of this reserve implementation */
		return 0;
	if(SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0;
	mgp = NULL;
	for(mg = mgp ? *mgp : SvMAGIC(sv); mg; mg = mgp ? *mgp : SvMAGIC(sv)) {
		if(mg->mg_type == type && mg->mg_virtual == vtbl) {
			if(mgp)
				*mgp = mg->mg_moremagic;
			else
				SvMAGIC_set(sv, mg->mg_moremagic);
			if(mg->mg_flags & MGf_REFCOUNTED)
				SvREFCNT_dec(mg->mg_obj);
			Safefree(mg);
		} else {
			mgp = &mg->mg_moremagic;
		}
	}
	SvMAGICAL_off(sv);
	mg_magical(sv);
	return 0;
}
#endif /* !sv_unmagicext */

MY_EXPORT_CALLCONV void QPFXD(gcp0)(pTHX_ CV *cv,
	Perl_call_parser *psfun_p, SV **psobj_p)
{
	MAGIC *callmg = SvMAGICAL((SV*)cv) ?
		mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_parsecall) : NULL;
	if(callmg) {
		*psfun_p = DPTR2FPTR(Perl_call_parser, callmg->mg_ptr);
		*psobj_p = callmg->mg_obj;
	} else {
		*psfun_p = DPTR2FPTR(Perl_call_parser, NULL);
		*psobj_p = NULL;
	}
}

MY_EXPORT_CALLCONV void QPFXD(scp0)(pTHX_ CV *cv,
	Perl_call_parser psfun, SV *psobj)
{
	if(
		(!psfun && !psobj)
#if Q_PARSER_AVAILABLE
		|| (psfun == Perl_parse_args_proto_or_list && psobj == (SV*)cv)
#endif /* Q_PARSER_AVAILABLE */
	) {
		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);