[gitmo/Class-MOP.git] / xs / Package.xs


#include "mop.h"


static void
mop_deconstruct_variable_name(pTHX_ SV* const variable,
    const char** const var_name, STRLEN* const var_name_len,
    svtype* const type,
    const char** const type_name) {


	if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
		/* e.g. variable = { type => "SCALAR", name => "foo" } */
		HV* const hv = (HV*)SvRV(variable);
		SV** svp;
		STRLEN len;
		const char* pv;

		svp = hv_fetchs(hv, "name", FALSE);
		if(!(svp && SvOK(*svp))){
			croak("You must pass a variable name");
		}
		*var_name     = SvPV_const(*svp, len);
		*var_name_len = len;
		if(len < 1){
			croak("You must pass a variable name");
		}

		svp = hv_fetchs(hv, "type", FALSE);
		if(!(svp && SvOK(*svp))) {
			croak("You must pass a variable type");
		}
		pv = SvPV_nolen_const(*svp);
		if(strEQ(pv, "SCALAR")){
			*type = SVt_PV; /* for all the type of scalars */
		}
		else if(strEQ(pv, "ARRAY")){
			*type = SVt_PVAV;
		}
		else if(strEQ(pv, "HASH")){
			*type = SVt_PVHV;
		}
		else if(strEQ(pv, "CODE")){
			*type = SVt_PVCV;
		}
		else if(strEQ(pv, "GLOB")){
			*type = SVt_PVGV;
		}
		else if(strEQ(pv, "IO")){
			*type = SVt_PVIO;
		}
		else{
			croak("I do not recognize that type '%s'", pv);
		}
		*type_name = pv;
	}
	else {
		STRLEN len;
		const char* pv;
		/* e.g. variable = '$foo' */
		if(!SvOK(variable)) {
			croak("You must pass a variable name");
		}
		pv = SvPV_const(variable, len);
		if(len < 2){
			croak("You must pass a variable name including a sigil");
		}

		*var_name     = pv  + 1;
		*var_name_len = len - 1;

		switch(pv[0]){
		case '$':
			*type      = SVt_PV; /* for all the types of scalars */
			*type_name = "SCALAR";
			break;
		case '@':
			*type      = SVt_PVAV;
			*type_name = "ARRAY";
			break;
		case '%':
			*type      = SVt_PVHV;
			*type_name = "HASH";
			break;
		case '&':
			*type      = SVt_PVCV;
			*type_name = "CODE";
			break;
		case '*':
			*type      = SVt_PVGV;
			*type_name = "GLOB";
			break;
		default:
			croak("I do not recognize that sigil '%c'", pv[0]);
		}
	}
}

static GV*
mop_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){
	SV* package_name;

	if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
		SV* const ns = mop_call0(aTHX_ self, mop_namespace);
		GV** gvp;
		if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
			croak("namespace() did not return a hash reference");
		}
		gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE);
		if(gvp && isGV_with_GP(*gvp)){
			return *gvp;
		}
	}

	package_name = mop_call0(aTHX_ self, KEY_FOR(name));

	if(!SvOK(package_name)){
		croak("name() did not return a defined value");
	}

	return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name), flags, type);
}

static SV*
mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
	SV* sv;

	if(!gv){
		return NULL;
	}

	assert(isGV_with_GP(gv));

	switch(type){
	case SVt_PVAV:
		sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
		break;
	case SVt_PVHV:
		sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
		break;
	case SVt_PVCV:
		sv = (SV*)GvCV(gv);
		break;
	case SVt_PVIO:
		sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
		break;
	case SVt_PVGV:
		sv = (SV*)gv;
		break;
	default: /* SCALAR */
		sv =       add ? GvSVn(gv) : GvSV(gv);
		break;
	}

	return sv;
}


MODULE = Class::MOP::Package   PACKAGE = Class::MOP::Package

PROTOTYPES: DISABLE

void
get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
    SV *self
    type_filter_t filter
    PREINIT:
        HV *stash = NULL;
        HV *symbols = NULL;
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call get_all_package_symbols as a class method");
        }

        if (GIMME_V == G_VOID) {
            XSRETURN_EMPTY;
        }

        PUTBACK;

        if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
            stash = gv_stashsv(HeVAL(he), 0);
        }


        if (!stash) {
            XSRETURN_UNDEF;
        }

        symbols = mop_get_all_package_symbols(stash, filter);
        PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));

BOOT:
    INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);


SV*
add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
PREINIT:
	svtype type;
	const char* type_name;
	const char* var_name;
	STRLEN var_name_len;
	GV* gv;
CODE:
	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);

	if(SvOK(ref)){ /* add_package_symbol with a value */
		if(type == SVt_PV){
			if(!SvROK(ref)){
				ref = newRV_noinc(newSVsv(ref));
				sv_2mortal(ref);
			}
		}
		else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
			croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
		}

		if(type == SVt_PVCV && GvCV(gv)){
			/* XXX: clear it before redefinition */
			SvREFCNT_dec(GvCV(gv));
			GvCV(gv) = NULL;
		}
		sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */

		if(type == SVt_PVCV){ /* name a subroutine */
			CV* const subr = (CV*)SvRV(ref);
			if(CvANON(subr)
				&& CvGV(subr)
				&& isGV(CvGV(subr))
				&& strEQ(GvNAME(CvGV(subr)), "__ANON__")){

				CvGV(subr) = gv;
				CvANON_off(subr);
			}
		}
		RETVAL = ref;
		SvREFCNT_inc_simple_void_NN(ref);
	}
	else{
		SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
		RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
	}
OUTPUT:
	RETVAL

bool
has_package_symbol(SV* self, SV* variable)
PREINIT:
	svtype type;
	const char* type_name;
	const char* var_name;
	STRLEN var_name_len;
	GV* gv;
CODE:
	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
	RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
OUTPUT:
	RETVAL

SV*
get_package_symbol(SV* self, SV* variable, ...)
PREINIT:
	svtype type;
	const char* type_name;
	const char* var_name;
	STRLEN var_name_len;
	I32 flags = 0;
	GV* gv;
	SV* sv;
CODE:
	{ /* parse options */
		I32 i;
		if((items % 2) != 0){
			croak("Odd number of arguments for get_package_symbol()");
		}
		for(i = 2; i < items; i += 2){
			SV* const opt = ST(i);
			SV* const val = ST(i+1);
			if(strEQ(SvPV_nolen_const(opt), "create")){
				if(SvTRUE(val)){
					flags |= GV_ADDMULTI;
				}
				else{
					flags &= ~GV_ADDMULTI;
				}
			}
			else{
				warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
			}
		}
	}
	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
	sv = mop_gv_elem(aTHX_ gv, type, FALSE);

	RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
OUTPUT:
	RETVAL
Commit	Line	Data
982b6f24	1
d846ade3	2	#include "mop.h"
d846ade3	3
982b6f24	4
e2e116c2	5	static void
	6	mop_deconstruct_variable_name(pTHX_ SV* const variable,
	7	const char** const var_name, STRLEN* const var_name_len,
	8	svtype* const type,
9742ab2a	9	const char** const type_name) {
e2e116c2	10
e170f134	11
	12	if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
	13	/* e.g. variable = { type => "SCALAR", name => "foo" } */
	14	HV* const hv = (HV*)SvRV(variable);
	15	SV** svp;
	16	STRLEN len;
	17	const char* pv;
	18
	19	svp = hv_fetchs(hv, "name", FALSE);
	20	if(!(svp && SvOK(*svp))){
	21	croak("You must pass a variable name");
	22	}
e2e116c2	23	var_name = SvPV_const(svp, len);
e2e116c2	24	*var_name_len = len;
e170f134	25	if(len < 1){
	26	croak("You must pass a variable name");
	27	}
	28
	29	svp = hv_fetchs(hv, "type", FALSE);
	30	if(!(svp && SvOK(*svp))) {
	31	croak("You must pass a variable type");
	32	}
	33	pv = SvPV_nolen_const(*svp);
	34	if(strEQ(pv, "SCALAR")){
	35	type = SVt_PV; / for all the type of scalars */
	36	}
	37	else if(strEQ(pv, "ARRAY")){
	38	*type = SVt_PVAV;
	39	}
	40	else if(strEQ(pv, "HASH")){
	41	*type = SVt_PVHV;
	42	}
	43	else if(strEQ(pv, "CODE")){
	44	*type = SVt_PVCV;
	45	}
	46	else if(strEQ(pv, "GLOB")){
	47	*type = SVt_PVGV;
	48	}
	49	else if(strEQ(pv, "IO")){
	50	*type = SVt_PVIO;
	51	}
	52	else{
	53	croak("I do not recognize that type '%s'", pv);
	54	}
	55	*type_name = pv;
	56	}
	57	else {
	58	STRLEN len;
	59	const char* pv;
	60	/* e.g. variable = '$foo' */
	61	if(!SvOK(variable)) {
	62	croak("You must pass a variable name");
	63	}
	64	pv = SvPV_const(variable, len);
	65	if(len < 2){
	66	croak("You must pass a variable name including a sigil");
	67	}
	68
e2e116c2	69	*var_name = pv + 1;
	70	*var_name_len = len - 1;
	71
e170f134	72	switch(pv[0]){
	73	case '$':
	74	type = SVt_PV; / for all the types of scalars */
	75	*type_name = "SCALAR";
	76	break;
	77	case '@':
	78	*type = SVt_PVAV;
	79	*type_name = "ARRAY";
	80	break;
	81	case '%':
	82	*type = SVt_PVHV;
	83	*type_name = "HASH";
	84	break;
	85	case '&':
	86	*type = SVt_PVCV;
	87	*type_name = "CODE";
	88	break;
	89	case '*':
	90	*type = SVt_PVGV;
	91	*type_name = "GLOB";
	92	break;
	93	default:
	94	croak("I do not recognize that sigil '%c'", pv[0]);
	95	}
e170f134	96	}
e170f134	97	}
e170f134	98
9742ab2a	99	static GV*
	100	mop_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){
	101	SV* package_name;
	102
	103	if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
	104	SV* const ns = mop_call0(aTHX_ self, mop_namespace);
	105	GV** gvp;
	106	if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
	107	croak("namespace() did not return a hash reference");
	108	}
	109	gvp = (GV*)hv_fetch((HV)SvRV(ns), var_name, var_name_len, FALSE);
	110	if(gvp && isGV_with_GP(*gvp)){
	111	return *gvp;
	112	}
	113	}
	114
	115	package_name = mop_call0(aTHX_ self, KEY_FOR(name));
	116
	117	if(!SvOK(package_name)){
	118	croak("name() did not return a defined value");
	119	}
	120
	121	return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name), flags, type);
	122	}
	123
	124	static SV*
	125	mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
	126	SV* sv;
	127
	128	if(!gv){
	129	return NULL;
	130	}
	131
	132	assert(isGV_with_GP(gv));
	133
	134	switch(type){
	135	case SVt_PVAV:
	136	sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
	137	break;
	138	case SVt_PVHV:
	139	sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
	140	break;
	141	case SVt_PVCV:
	142	sv = (SV*)GvCV(gv);
	143	break;
	144	case SVt_PVIO:
	145	sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
	146	break;
	147	case SVt_PVGV:
	148	sv = (SV*)gv;
	149	break;
	150	default: /* SCALAR */
	151	sv = add ? GvSVn(gv) : GvSV(gv);
	152	break;
	153	}
	154
	155	return sv;
	156	}
	157
	158
d846ade3	159	MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package
	160
	161	PROTOTYPES: DISABLE
	162
	163	void
	164	get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
	165	SV *self
	166	type_filter_t filter
	167	PREINIT:
	168	HV *stash = NULL;
	169	HV *symbols = NULL;
	170	register HE *he;
	171	PPCODE:
	172	if ( ! SvROK(self) ) {
	173	die("Cannot call get_all_package_symbols as a class method");
	174	}
	175
	176	if (GIMME_V == G_VOID) {
	177	XSRETURN_EMPTY;
	178	}
	179
	180	PUTBACK;
	181
22932438	182	if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
d846ade3	183	stash = gv_stashsv(HeVAL(he), 0);
	184	}
	185
	186
	187	if (!stash) {
	188	XSRETURN_UNDEF;
	189	}
	190
e1f52a8a	191	symbols = mop_get_all_package_symbols(stash, filter);
d846ade3	192	PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
d846ade3	193
7ec7b950	194	BOOT:
7ec7b950	195	INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
e170f134	196
e2e116c2	197
e170f134	198	SV*
	199	add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
	200	PREINIT:
	201	svtype type;
	202	const char* type_name;
982b6f24	203	const char* var_name;
e2e116c2	204	STRLEN var_name_len;
e2e116c2	205	GV* gv;
e170f134	206	CODE:
9742ab2a	207	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
9742ab2a	208	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
e2e116c2	209
e2e116c2	210	if(SvOK(ref)){ /* add_package_symbol with a value */
e170f134	211	if(type == SVt_PV){
	212	if(!SvROK(ref)){
	213	ref = newRV_noinc(newSVsv(ref));
	214	sv_2mortal(ref);
	215	}
	216	}
	217	else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
	218	croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
	219	}
e170f134	220
e170f134	221	if(type == SVt_PVCV && GvCV(gv)){
9742ab2a	222	/* XXX: clear it before redefinition */
e170f134	223	SvREFCNT_dec(GvCV(gv));
	224	GvCV(gv) = NULL;
	225	}
9742ab2a	226	sv_setsv_mg((SV)gv, ref); / magical assignment into type glob (glob = $ref) /
7b0b8bad	227
9742ab2a	228	if(type == SVt_PVCV){ /* name a subroutine */
7b0b8bad	229	CV* const subr = (CV*)SvRV(ref);
	230	if(CvANON(subr)
	231	&& CvGV(subr)
	232	&& isGV(CvGV(subr))
	233	&& strEQ(GvNAME(CvGV(subr)), "__ANON__")){
9742ab2a	234
7b0b8bad	235	CvGV(subr) = gv;
	236	CvANON_off(subr);
	237	}
	238	}
e170f134	239	RETVAL = ref;
9742ab2a	240	SvREFCNT_inc_simple_void_NN(ref);
e170f134	241	}
9742ab2a	242	else{
	243	SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
	244	RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
	245	}
	246	OUTPUT:
	247	RETVAL
982b6f24	248
9742ab2a	249	bool
	250	has_package_symbol(SV* self, SV* variable)
	251	PREINIT:
	252	svtype type;
	253	const char* type_name;
	254	const char* var_name;
	255	STRLEN var_name_len;
	256	GV* gv;
	257	CODE:
	258	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
	259	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
	260	RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
	261	OUTPUT:
	262	RETVAL
e170f134	263
9742ab2a	264	SV*
	265	get_package_symbol(SV* self, SV* variable, ...)
	266	PREINIT:
	267	svtype type;
	268	const char* type_name;
	269	const char* var_name;
	270	STRLEN var_name_len;
	271	I32 flags = 0;
	272	GV* gv;
	273	SV* sv;
	274	CODE:
	275	{ /* parse options */
	276	I32 i;
	277	if((items % 2) != 0){
	278	croak("Odd number of arguments for get_package_symbol()");
e170f134	279	}
9742ab2a	280	for(i = 2; i < items; i += 2){
	281	SV* const opt = ST(i);
	282	SV* const val = ST(i+1);
	283	if(strEQ(SvPV_nolen_const(opt), "create")){
	284	if(SvTRUE(val)){
	285	flags \|= GV_ADDMULTI;
	286	}
	287	else{
	288	flags &= ~GV_ADDMULTI;
	289	}
982b6f24	290	}
982b6f24	291	else{
9742ab2a	292	warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
982b6f24	293	}
e170f134	294	}
e170f134	295	}
9742ab2a	296	mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
	297	gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
	298	sv = mop_gv_elem(aTHX_ gv, type, FALSE);
e170f134	299
9742ab2a	300	RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
	301	OUTPUT:
	302	RETVAL