view release on metacpan or  search on metacpan

lib/Data/Util.xs  view on Meta::CPAN

			my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv)));
		}

		for(i = 1; i < items; i += 2){
			SV* const as           = my_string(aTHX_ ST(i), "a subroutine name");
			STRLEN namelen;
			const char* const name = SvPV_const(as, namelen);
			SV* const code_ref     = ST(i+1);

			my_install_sub(aTHX_ stash, name, namelen, code_ref);
		}
	}

void
uninstall_subroutine(package, ...)
	SV* package
PREINIT:
	HV* stash;
	int i;
CODE:
	stash = gv_stashsv(my_string(aTHX_ package, "a package name"), FALSE);
	if(!stash) XSRETURN_EMPTY;

	if(items == 2 && SvROK(ST(1))){
		HV* const hv = deref_hv(ST(1));
		I32   namelen;
		char* name;
		SV* specified_code_ref;

		hv_iterinit(hv);
		while((specified_code_ref = hv_iternextsv(hv, &name, &namelen))){
			my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref);
		}
	}
	else{
		for(i = 1; i < items; i++){
			SV* const namesv = my_string(aTHX_ ST(i), "a subroutine name");
			STRLEN namelen;
			const char* const name = SvPV_const(namesv, namelen);
			SV* specified_code_ref;

			if( (i+1) < items && SvROK(ST(i+1)) ){
				i++;
				specified_code_ref = ST(i);
			}
			else{
				specified_code_ref = &PL_sv_undef;
			}

			my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref);
		}
	}
	mro_method_changed_in(stash);

void
get_code_info(code)
	CV* code
PREINIT:
	GV* gv;
	HV* stash;
PPCODE:
	if( (gv = CvGV(code)) && isGV_with_GP(gv)
		&& (stash = (GvSTASH(gv))) && HvNAME_get(stash) ){

		if(GIMME_V == G_ARRAY){
			EXTEND(SP, 2);
			mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
			mPUSHs(newSVpvn_share(GvNAME(gv), GvNAMELEN(gv), 0U));
		}
		else{
			SV* const sv = newSVpvf("%s::%s", HvNAME_get(stash), GvNAME(gv));
			mXPUSHs(sv);
		}
	}


SV*
get_code_ref(package, name, ...)
	SV* package
	SV* name
INIT:
	I32 flags = 0;
	RETVAL = &PL_sv_undef;
CODE:
	(void)my_string(aTHX_ package, "a package name");
	(void)my_string(aTHX_ name,    "a subroutine name");

	if(items > 2){ /* with flags */
		I32 i;
		for(i = 2; i < items; i++){
			SV* const sv = my_string(aTHX_ ST(i), "a flag");
			if(strEQ(SvPV_nolen_const(sv), "-create")){
				flags |= GV_ADD;
			}
			else{
				my_fail(aTHX_ "a flag", sv);
			}
		}
	}

	{
		HV* const stash = gv_stashsv(package, flags);

		if(stash){
			STRLEN len;
			const char* const pv = SvPV_const(name, len);
			GV** const gvp = (GV**)hv_fetch(stash, pv, len, flags);
			GV*  const gv  = gvp ? *gvp : NULL;

			if(gv){
				if(!isGV(gv)) gv_init(gv, stash, pv, len, GV_ADDMULTI);

				if(GvCVu(gv)){
					RETVAL = newRV_inc((SV*)GvCV(gv));
				}
				else if(flags & GV_ADD){
					SV* const sv = Perl_newSVpvf(aTHX_ "%"SVf"::%"SVf, package, name);

					/* from Perl_get_cvn_flags() in perl.c */
					CV* const cv = newSUB(
						start_subparse(FALSE, 0),

lib/Data/Util.xs  view on Meta::CPAN

		const char* const modifier_type = SvPV_nolen_const(mtsv);
		AV*         const          subs = deref_av(ST(i+1));
		I32         const      subs_len = av_len(subs) + 1;
		AV* av = NULL;
		I32 j;

		if(strEQ(modifier_type, "before")){
			av = before;
		}
		else if(strEQ(modifier_type, "around")){
			av = around;
		}
		else if(strEQ(modifier_type, "after")){
			av = after;
		}
		else{
			my_fail(aTHX_ "a modifier type", mtsv);
		}

		av_extend(av, AvFILLp(av) + subs_len - 1);
		for(j = 0; j < subs_len; j++){
			SV* const code_ref = newSVsv(validate(*av_fetch(subs, j, TRUE), T_CV));

			av_push(av, code_ref);
		}
	}

	modifiers = newAV();
	av_extend(modifiers, 3);

	av_store(modifiers, M_CURRENT,  my_build_around_code(aTHX_ code, around));

	av_store(modifiers, M_BEFORE, SvREFCNT_inc_simple_NN(before));
	av_store(modifiers, M_AROUND, SvREFCNT_inc_simple_NN(around));
	av_store(modifiers, M_AFTER,  SvREFCNT_inc_simple_NN(after));

	modified = newXS(NULL /* anonymous */, XS_Data__Util_modified, __FILE__);

	mg = sv_magicext((SV*)modified, (SV*)modifiers, PERL_MAGIC_ext, &modified_vtbl, NULL, 0);
	SvREFCNT_dec((SV*)modifiers); /* refcnt++ in sv_magicext() */
	CvXSUBANY(modified).any_ptr = (void*)mg;

	RETVAL = newRV_noinc((SV*)modified);
OUTPUT:
	RETVAL


void
subroutine_modifier(code, ...)
	CV* code
PREINIT:
	/* Usage:
		subroutine_modifier(code)                 # check
		subroutine_modifier(code, property)       # get
		subroutine_modifier(code, property, subs) # set
	*/
	MAGIC* mg;
	AV* modifiers; /* (before, around, after, original, current) */
	SV* property;
	const char* property_pv;
PPCODE:
	mg = mg_find_by_vtbl((SV*)code, &modified_vtbl);

	if(items == 1){ /* check only */
		ST(0) = boolSV(mg);
		XSRETURN(1);
	}

	if(!mg){
		my_fail(aTHX_ "a modified subroutine", ST(0) /* ref to code */);
	}

	modifiers = (AV*)mg->mg_obj;
	assert(modifiers);

	property = my_string(aTHX_ ST(1), "a modifier property");
	property_pv = SvPV_nolen_const(property);

	if(strEQ(property_pv, "before") || strEQ(property_pv, "around") || strEQ(property_pv, "after")){
		I32 const idx =
			  strEQ(property_pv, "before") ? M_BEFORE
			: strEQ(property_pv, "around") ? M_AROUND
			:                                M_AFTER;
		AV* const av = (AV*)*av_fetch(modifiers, idx, FALSE);
		if(items != 2){ /* add */
			I32 i;
			for(i = 2; i < items; i++){
				SV* const code_ref = newSVsv(validate(ST(i), T_CV));
				if(idx == M_AFTER){
					av_push(av, code_ref);
				}
				else{
					av_unshift(av, 1);
					av_store(av, 0, code_ref);
				}
			}

			if(idx == M_AROUND){
				AV* const around = (AV*)sv_2mortal((SV*)av_make(items-2, &ST(2)));
				SV* const current = my_build_around_code(aTHX_
						*av_fetch(modifiers, M_CURRENT, FALSE),
						around
					);
				av_store(modifiers, M_CURRENT, current);
			}
		}
		XPUSHary(AvARRAY(av), 0, AvFILLp(av)+1);
	}
	else{
		my_fail(aTHX_ "a modifier property", property);
	}



#define mkopt(opt_list, moniker, require_unique, must_be) \
		my_mkopt(aTHX_ opt_list, moniker, require_unique, must_be, T_AV)
#define mkopt_hash(opt_list, moniker, must_be) \
		my_mkopt(aTHX_ opt_list, moniker, TRUE, must_be, T_HV)


SV*