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

/* There's a lot of cases of doubled parens in here like this:

  while ( (he = ...) ) {

This shuts up warnings from gcc -Wall
*/

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_sv_2pv_flags
#define NEED_sv_2pv_nolen
#include "ppport.h"

SV *key_name;
U32 hash_name;

SV *key_package;
U32 hash_package;

SV *key_package_name;
U32 hash_package_name;

SV *key_body;
U32 hash_body;

SV* method_metaclass;
SV* associated_metaclass;
SV* wrap;


#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
#ifdef HvMROMETA /* 5.10.0 */

#ifndef mro_meta_init
#define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
#endif /* !mro_meta_init */

static UV
mop_check_package_cache_flag(pTHX_ HV* stash) {
    assert(SvTYPE(stash) == SVt_PVHV);

    return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
}

#else /* pre 5.10.0 */

static UV
mop_check_package_cache_flag(pTHX_ HV* stash) {
    PERL_UNUSED_ARG(stash);
    assert(SvTYPE(stash) == SVt_PVHV);

    return PL_sub_generation;
}
#endif

#define call0(s, m)  mop_call0(aTHX_ s, m)
static SV*
mop_call0(pTHX_ SV* const self, SV* const method) {
    dSP;
    SV* ret;

    PUSHMARK(SP);
    XPUSHs(self);
    PUTBACK;

    call_sv(method, G_SCALAR | G_METHOD);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    return ret;
}

static void
mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
    const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
    SV*   method_metaclass_name;
    char* method_name;
    I32   method_name_len;
    GV* gv;
    dSP;

    /* this function massivly overlaps with the xs version of
     * get_all_package_symbols. a common c function to walk the symbol table
     * should be factored out and used by both.  --rafl */

    hv_iterinit(stash);
    while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
        CV* cv;
        switch (SvTYPE (gv)) {
#ifndef SVt_RV
            case SVt_RV:
#endif
            case SVt_IV:
            case SVt_PV:
                /* rafl says that this wastes memory savings that GvSVs have
                   in 5.8.9 and 5.10.x. But without it some tests fail. rafl
                   says the right thing to do is to handle GvSVs differently
                   here. */
                gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
                /* fall through */
            default:
                break;
        }

        if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
            GV* const cvgv = CvGV(cv);
            /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
            const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
            const char* const cv_name    = GvNAME(cvgv);
            SV* method_slot;
            SV* method_object;

            /* this checks to see that the subroutine is actually from our package  */
            if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
                if ( strNE(cvpkg_name, class_name_pv) ) {
                    continue;
                }
            }

            method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
            if ( SvOK(method_slot) ) {
                SV* const body = call0(method_slot, key_body); /* $method_object->body() */
                if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
                    continue;
                }
            }

            method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */

            /*
                $method_object = $method_metaclass->wrap(
                    $cv,
                    associated_metaclass => $self,
                    package_name         => $class_name,
                    name                 => $method_name
                );
            */
            ENTER;
            SAVETMPS;

            PUSHMARK(SP);
            EXTEND(SP, 8);
            PUSHs(method_metaclass_name); /* invocant */
            mPUSHs(newRV_inc((SV*)cv));
            PUSHs(associated_metaclass);
            PUSHs(self);
            PUSHs(key_package_name);
            PUSHs(class_name);
            PUSHs(key_name);
            mPUSHs(newSVpv(method_name, method_name_len));
            PUTBACK;

            call_sv(wrap, G_SCALAR | G_METHOD);
            SPAGAIN;
            method_object = POPs;
            PUTBACK;
            /* $map->{$method_name} = $method_object */
            sv_setsv(method_slot, method_object);

            FREETMPS;
            LEAVE;
        }
    }
}

typedef enum {
    TYPE_FILTER_NONE,
    TYPE_FILTER_CODE,
    TYPE_FILTER_ARRAY,
    TYPE_FILTER_IO,
    TYPE_FILTER_HASH,
    TYPE_FILTER_SCALAR,
} type_filter_t;

static HV *
get_all_package_symbols(HV *stash, type_filter_t filter)
{
    HE *he;
    HV *ret = newHV();

    (void)hv_iterinit(stash);

    if (filter == TYPE_FILTER_NONE) {
        while ( (he = hv_iternext(stash)) ) {
            STRLEN keylen;
            char *key = HePV(he, keylen);
            hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0);
        }

        return ret;
    }

    while ( (he = hv_iternext(stash)) ) {
        SV *const gv = HeVAL(he);
        SV *sv = NULL;
        char *key;
        STRLEN keylen;
        char *package;
        SV *fq;

        switch( SvTYPE(gv) ) {
#ifndef SVt_RV
            case SVt_RV:
#endif
            case SVt_PV:
            case SVt_IV:
                /* expand the gv into a real typeglob if it
                 * contains stub functions and we were asked to
                 * return CODE symbols */
                if (filter == TYPE_FILTER_CODE) {
                    if (SvROK(gv)) {
                        /* we don't really care about the length,
                           but that's the API */
                        key = HePV(he, keylen);
                        package = HvNAME(stash);
                        fq = newSVpvf("%s::%s", package, key);
                        sv = (SV *)get_cv(SvPV_nolen(fq), 0);
                        break;
                    }

                    key = HePV(he, keylen);
                    gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
                }
                /* fall through */
            case SVt_PVGV:
                switch (filter) {
                    case TYPE_FILTER_CODE:   sv = (SV *)GvCVu(gv); break;
                    case TYPE_FILTER_ARRAY:  sv = (SV *)GvAV(gv);  break;
                    case TYPE_FILTER_IO:     sv = (SV *)GvIO(gv);  break;
                    case TYPE_FILTER_HASH:   sv = (SV *)GvHV(gv);  break;
                    case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv);  break;
                    default:
                        croak("Unknown type");
                }
                break;
            default:
                continue;
        }

        if (sv) {
            char *key = HePV(he, keylen);
            hv_store(ret, key, keylen, newRV_inc(sv), 0);
        }
    }

    return ret;
}

/*
get_code_info:
  Pass in a coderef, returns:
  [ $pkg_name, $coderef_name ] ie:
  [ 'Foo::Bar', 'new' ]
*/

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

BOOT:
    key_name = newSVpvs("name");
    key_body = newSVpvs("body");
    key_package = newSVpvs("package");
    key_package_name = newSVpvs("package_name");

    PERL_HASH(hash_name, "name", 4);
    PERL_HASH(hash_body, "body", 4);
    PERL_HASH(hash_package, "package", 7);
    PERL_HASH(hash_package_name, "package_name", 12);

    method_metaclass     = newSVpvs("method_metaclass");
    wrap                 = newSVpvs("wrap");
    associated_metaclass = newSVpvs("associated_metaclass");


PROTOTYPES: ENABLE


void
get_code_info(coderef)
  SV* coderef
  PREINIT:
    char* name;
    char* pkg;
  PPCODE:
    if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
      coderef = SvRV(coderef);
      /* I think this only gets triggered with a mangled coderef, but if
         we hit it without the guard, we segfault. The slightly odd return
         value strikes me as an improvement (mst)
      */
#ifdef isGV_with_GP
      if ( isGV_with_GP(CvGV(coderef)) ) {
#endif
        pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
        name    = GvNAME( CvGV(coderef) );
#ifdef isGV_with_GP
      } else {
        pkg     = "__UNKNOWN__";
        name    = "__ANON__";
      }
#endif

      EXTEND(SP, 2);
      PUSHs(newSVpvn(pkg, strlen(pkg)));
      PUSHs(newSVpvn(name, strlen(name)));
    }


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

void
get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
    SV *self
    type_filter_t filter
    PROTOTYPE: $;$
    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;
        }

        switch (GIMME_V) {
            case G_VOID: return; break;
            case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
        }

        PUTBACK;

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
            stash = gv_stashsv(HeVAL(he), 0);
        }


        if (!stash) {
            XSRETURN_EMPTY;
        }

        symbols = get_all_package_symbols(stash, filter);

        EXTEND(SP, HvKEYS(symbols) * 2);
        while ((he = hv_iternext(symbols))) {
            PUSHs(hv_iterkeysv(he));
            PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
        }

        SvREFCNT_dec((SV *)symbols);

void
name(self)
    SV *self
    PREINIT:
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call name as a class method");
        }

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
            XPUSHs(HeVAL(he));
        else
            ST(0) = &PL_sv_undef;

MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute

void
name(self)
    SV *self
    PREINIT:
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call name as a class method");
        }

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
            XPUSHs(HeVAL(he));
        else
            ST(0) = &PL_sv_undef;

MODULE = Class::MOP   PACKAGE = Class::MOP::Method

void
name(self)
    SV *self
    PREINIT:
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call name as a class method");
        }

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
            XPUSHs(HeVAL(he));
        else
            ST(0) = &PL_sv_undef;

void
package_name(self)
    SV *self
    PREINIT:
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call package_name as a class method");
        }

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
            XPUSHs(HeVAL(he));
        else
            ST(0) = &PL_sv_undef;

void
body(self)
    SV *self
    PREINIT:
        register HE *he;
    PPCODE:
        if ( ! SvROK(self) ) {
            die("Cannot call body as a class method");
        }

        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
            XPUSHs(HeVAL(he));
        else
            ST(0) = &PL_sv_undef;


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

void
get_method_map(self)
    SV* self
    PREINIT:
        SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
        HV* const stash      = gv_stashsv(class_name, TRUE);
        UV  const current    = check_package_cache_flag(stash);
        SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
        SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
    PPCODE:
        if ( ! SvRV(self) ) {
            die("Cannot call get_method_map as a class method");
        }

        /* in  $self->{methods} does not yet exist (or got deleted) */
        if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
            SV* new_map_ref = newRV_noinc((SV*)newHV());
            sv_2mortal(new_map_ref);
            sv_setsv(map_ref, new_map_ref);
        }

        if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
            ENTER;
            SAVETMPS;

            mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
            sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */

            FREETMPS;
            LEAVE;
        }

        XPUSHs(map_ref);
Commit	Line	Data
e7b69038	1	/* There's a lot of cases of doubled parens in here like this:
	2
	3	while ( (he = ...) ) {
	4
	5	This shuts up warnings from gcc -Wall
	6	*/
	7
e0e4674a	8	#include "EXTERN.h"
	9	#include "perl.h"
	10	#include "XSUB.h"
15273f3c	11
599791aa	12	#define NEED_sv_2pv_flags
15273f3c	13	#define NEED_sv_2pv_nolen
b0e94057	14	#include "ppport.h"
e0e4674a	15
cc856b56	16	SV *key_name;
	17	U32 hash_name;
	18
	19	SV *key_package;
	20	U32 hash_package;
	21
da88f307	22	SV *key_package_name;
	23	U32 hash_package_name;
	24
cc856b56	25	SV *key_body;
	26	U32 hash_body;
	27
c94afdc4	28	SV* method_metaclass;
	29	SV* associated_metaclass;
	30	SV* wrap;
	31
	32
	33	#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
	34	#ifdef HvMROMETA /* 5.10.0 */
	35
	36	#ifndef mro_meta_init
	37	#define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
	38	#endif /* !mro_meta_init */
	39
	40	static UV
	41	mop_check_package_cache_flag(pTHX_ HV* stash) {
	42	assert(SvTYPE(stash) == SVt_PVHV);
	43
	44	return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
	45	}
	46
	47	#else /* pre 5.10.0 */
	48
	49	static UV
	50	mop_check_package_cache_flag(pTHX_ HV* stash) {
	51	PERL_UNUSED_ARG(stash);
	52	assert(SvTYPE(stash) == SVt_PVHV);
	53
	54	return PL_sub_generation;
	55	}
	56	#endif
	57
	58	#define call0(s, m) mop_call0(aTHX_ s, m)
	59	static SV*
	60	mop_call0(pTHX_ SV* const self, SV* const method) {
	61	dSP;
	62	SV* ret;
	63
	64	PUSHMARK(SP);
	65	XPUSHs(self);
	66	PUTBACK;
	67
	68	call_sv(method, G_SCALAR \| G_METHOD);
	69
	70	SPAGAIN;
	71	ret = POPs;
	72	PUTBACK;
	73
	74	return ret;
	75	}
	76
	77	static void
	78	mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
	79	const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
	80	SV* method_metaclass_name;
	81	char* method_name;
	82	I32 method_name_len;
	83	GV* gv;
	84	dSP;
49bbf9e5	85
6bd19edb	86	/* this function massivly overlaps with the xs version of
	87	* get_all_package_symbols. a common c function to walk the symbol table
	88	* should be factored out and used by both. --rafl */
	89
c94afdc4	90	hv_iterinit(stash);
e7b69038	91	while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
c94afdc4	92	CV* cv;
6bd19edb	93	switch (SvTYPE (gv)) {
cb0ec494	94	#ifndef SVt_RV
6bd19edb	95	case SVt_RV:
cb0ec494	96	#endif
6bd19edb	97	case SVt_IV:
	98	case SVt_PV:
	99	/* rafl says that this wastes memory savings that GvSVs have
	100	in 5.8.9 and 5.10.x. But without it some tests fail. rafl
	101	says the right thing to do is to handle GvSVs differently
	102	here. */
	103	gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
	104	/* fall through */
733e8831	105	default:
733e8831	106	break;
c94afdc4	107	}
	108
	109	if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
	110	GV* const cvgv = CvGV(cv);
	111	/* ($cvpkg_name, $cv_name) = get_code_info($cv) */
	112	const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
	113	const char* const cv_name = GvNAME(cvgv);
	114	SV* method_slot;
	115	SV* method_object;
	116
	117	/* this checks to see that the subroutine is actually from our package */
	118	if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
	119	if ( strNE(cvpkg_name, class_name_pv) ) {
	120	continue;
	121	}
	122	}
	123
	124	method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
	125	if ( SvOK(method_slot) ) {
	126	SV* const body = call0(method_slot, key_body); /* $method_object->body() */
	127	if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
	128	continue;
	129	}
	130	}
	131
	132	method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
	133
	134	/*
	135	$method_object = $method_metaclass->wrap(
	136	$cv,
	137	associated_metaclass => $self,
	138	package_name => $class_name,
	139	name => $method_name
	140	);
	141	*/
	142	ENTER;
	143	SAVETMPS;
	144
	145	PUSHMARK(SP);
	146	EXTEND(SP, 8);
	147	PUSHs(method_metaclass_name); /* invocant */
	148	mPUSHs(newRV_inc((SV*)cv));
	149	PUSHs(associated_metaclass);
	150	PUSHs(self);
	151	PUSHs(key_package_name);
	152	PUSHs(class_name);
	153	PUSHs(key_name);
	154	mPUSHs(newSVpv(method_name, method_name_len));
	155	PUTBACK;
	156
	157	call_sv(wrap, G_SCALAR \| G_METHOD);
	158	SPAGAIN;
	159	method_object = POPs;
	160	PUTBACK;
	161	/* $map->{$method_name} = $method_object */
	162	sv_setsv(method_slot, method_object);
	163
	164	FREETMPS;
	165	LEAVE;
	166	}
	167	}
	168	}
	169
b49ee39f	170	typedef enum {
	171	TYPE_FILTER_NONE,
	172	TYPE_FILTER_CODE,
	173	TYPE_FILTER_ARRAY,
	174	TYPE_FILTER_IO,
	175	TYPE_FILTER_HASH,
	176	TYPE_FILTER_SCALAR,
	177	} type_filter_t;
	178
	179	static HV *
	180	get_all_package_symbols(HV *stash, type_filter_t filter)
	181	{
	182	HE *he;
	183	HV *ret = newHV();
	184
	185	(void)hv_iterinit(stash);
	186
	187	if (filter == TYPE_FILTER_NONE) {
	188	while ( (he = hv_iternext(stash)) ) {
	189	STRLEN keylen;
	190	char *key = HePV(he, keylen);
	191	hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0);
	192	}
	193
	194	return ret;
	195	}
	196
	197	while ( (he = hv_iternext(stash)) ) {
	198	SV *const gv = HeVAL(he);
	199	SV *sv = NULL;
	200	char *key;
	201	STRLEN keylen;
	202	char *package;
	203	SV *fq;
	204
	205	switch( SvTYPE(gv) ) {
	206	#ifndef SVt_RV
	207	case SVt_RV:
	208	#endif
	209	case SVt_PV:
	210	case SVt_IV:
	211	/* expand the gv into a real typeglob if it
	212	* contains stub functions and we were asked to
	213	* return CODE symbols */
	214	if (filter == TYPE_FILTER_CODE) {
	215	if (SvROK(gv)) {
	216	/* we don't really care about the length,
	217	but that's the API */
	218	key = HePV(he, keylen);
	219	package = HvNAME(stash);
	220	fq = newSVpvf("%s::%s", package, key);
	221	sv = (SV *)get_cv(SvPV_nolen(fq), 0);
	222	break;
	223	}
	224
	225	key = HePV(he, keylen);
	226	gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
	227	}
	228	/* fall through */
	229	case SVt_PVGV:
	230	switch (filter) {
	231	case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break;
	232	case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break;
	233	case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break;
234	case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break;
235	case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break;
236	default:
237	croak("Unknown type");
238	}
239	break;
240	default:
241	continue;
242	}
243
244	if (sv) {
245	char *key = HePV(he, keylen);
246	hv_store(ret, key, keylen, newRV_inc(sv), 0);
247	}
248	}
249
250	return ret;
251	}
c94afdc4	252
e0e4674a	253	/*
e0e4674a	254	get_code_info:
	255	Pass in a coderef, returns:
	256	[ $pkg_name, $coderef_name ] ie:
	257	[ 'Foo::Bar', 'new' ]
	258	*/
	259
	260	MODULE = Class::MOP PACKAGE = Class::MOP
	261
cc856b56	262	BOOT:
	263	key_name = newSVpvs("name");
	264	key_body = newSVpvs("body");
	265	key_package = newSVpvs("package");
da88f307	266	key_package_name = newSVpvs("package_name");
cc856b56	267
	268	PERL_HASH(hash_name, "name", 4);
	269	PERL_HASH(hash_body, "body", 4);
	270	PERL_HASH(hash_package, "package", 7);
da88f307	271	PERL_HASH(hash_package_name, "package_name", 12);
cc856b56	272
c94afdc4	273	method_metaclass = newSVpvs("method_metaclass");
	274	wrap = newSVpvs("wrap");
	275	associated_metaclass = newSVpvs("associated_metaclass");
	276
cc856b56	277
d7bf3478	278	PROTOTYPES: ENABLE
d7bf3478	279
cc856b56	280
e0e4674a	281	void
	282	get_code_info(coderef)
	283	SV* coderef
	284	PREINIT:
	285	char* name;
	286	char* pkg;
	287	PPCODE:
a7f711e5	288	if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
e0e4674a	289	coderef = SvRV(coderef);
7b62d87f	290	/* I think this only gets triggered with a mangled coderef, but if
	291	we hit it without the guard, we segfault. The slightly odd return
	292	value strikes me as an improvement (mst)
	293	*/
a4f4221a	294	#ifdef isGV_with_GP
a7f711e5	295	if ( isGV_with_GP(CvGV(coderef)) ) {
a4f4221a	296	#endif
7b62d87f	297	pkg = HvNAME( GvSTASH(CvGV(coderef)) );
7b62d87f	298	name = GvNAME( CvGV(coderef) );
a4f4221a	299	#ifdef isGV_with_GP
	300	} else {
	301	pkg = "__UNKNOWN__";
	302	name = "__ANON__";
	303	}
	304	#endif
e0e4674a	305
	306	EXTEND(SP, 2);
	307	PUSHs(newSVpvn(pkg, strlen(pkg)));
	308	PUSHs(newSVpvn(name, strlen(name)));
	309	}
	310
15273f3c	311
	312	MODULE = Class::MOP PACKAGE = Class::MOP::Package
	313
	314	void
b49ee39f	315	get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
cc856b56	316	SV *self
b49ee39f	317	type_filter_t filter
15273f3c	318	PROTOTYPE: $;$
15273f3c	319	PREINIT:
cc856b56	320	HV *stash = NULL;
b49ee39f	321	HV *symbols = NULL;
75705e60	322	register HE *he;
15273f3c	323	PPCODE:
a7f711e5	324	if ( ! SvROK(self) ) {
988fb42e	325	die("Cannot call get_all_package_symbols as a class method");
988fb42e	326	}
15273f3c	327
b49ee39f	328	if (GIMME_V == G_VOID) {
	329	XSRETURN_EMPTY;
	330	}
	331
a7f711e5	332	switch (GIMME_V) {
15273f3c	333	case G_VOID: return; break;
	334	case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
	335	}
	336
15273f3c	337	PUTBACK;
15273f3c	338
b49ee39f	339	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
	340	stash = gv_stashsv(HeVAL(he), 0);
	341	}
15273f3c	342
15273f3c	343
b49ee39f	344	if (!stash) {
	345	XSRETURN_EMPTY;
	346	}
15273f3c	347
b49ee39f	348	symbols = get_all_package_symbols(stash, filter);
15273f3c	349
b49ee39f	350	EXTEND(SP, HvKEYS(symbols) * 2);
	351	while ((he = hv_iternext(symbols))) {
	352	PUSHs(hv_iterkeysv(he));
	353	PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
15273f3c	354	}
15273f3c	355
b49ee39f	356	SvREFCNT_dec((SV *)symbols);
b49ee39f	357
e2c189ae	358	void
cc856b56	359	name(self)
	360	SV *self
	361	PREINIT:
	362	register HE *he;
	363	PPCODE:
a7f711e5	364	if ( ! SvROK(self) ) {
988fb42e	365	die("Cannot call name as a class method");
	366	}
	367
e7b69038	368	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
cc856b56	369	XPUSHs(HeVAL(he));
	370	else
	371	ST(0) = &PL_sv_undef;
	372
dcbfe027	373	MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
cc856b56	374
e2c189ae	375	void
cc856b56	376	name(self)
	377	SV *self
	378	PREINIT:
	379	register HE *he;
	380	PPCODE:
a7f711e5	381	if ( ! SvROK(self) ) {
988fb42e	382	die("Cannot call name as a class method");
	383	}
	384
e7b69038	385	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
cc856b56	386	XPUSHs(HeVAL(he));
	387	else
	388	ST(0) = &PL_sv_undef;
	389
dcbfe027	390	MODULE = Class::MOP PACKAGE = Class::MOP::Method
cc856b56	391
e2c189ae	392	void
da88f307	393	name(self)
	394	SV *self
	395	PREINIT:
	396	register HE *he;
	397	PPCODE:
a7f711e5	398	if ( ! SvROK(self) ) {
da88f307	399	die("Cannot call name as a class method");
	400	}
	401
e7b69038	402	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
da88f307	403	XPUSHs(HeVAL(he));
	404	else
	405	ST(0) = &PL_sv_undef;
	406
e2c189ae	407	void
da88f307	408	package_name(self)
	409	SV *self
	410	PREINIT:
	411	register HE *he;
	412	PPCODE:
a7f711e5	413	if ( ! SvROK(self) ) {
da88f307	414	die("Cannot call package_name as a class method");
	415	}
	416
e7b69038	417	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
da88f307	418	XPUSHs(HeVAL(he));
	419	else
	420	ST(0) = &PL_sv_undef;
	421
e2c189ae	422	void
cc856b56	423	body(self)
	424	SV *self
	425	PREINIT:
	426	register HE *he;
	427	PPCODE:
a7f711e5	428	if ( ! SvROK(self) ) {
da88f307	429	die("Cannot call body as a class method");
	430	}
	431
e7b69038	432	if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
cc856b56	433	XPUSHs(HeVAL(he));
	434	else
	435	ST(0) = &PL_sv_undef;
c94afdc4	436
	437
	438	MODULE = Class::MOP PACKAGE = Class::MOP::Class
	439
	440	void
	441	get_method_map(self)
	442	SV* self
c200a770	443	PREINIT:
b69838b1	444	SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
c200a770	445	HV* const stash = gv_stashsv(class_name, TRUE);
	446	UV const current = check_package_cache_flag(stash);
	447	SV* const cache_flag = hv_fetchs((HV)SvRV(self), "_package_cache_flag", TRUE);
	448	SV* const map_ref = hv_fetchs((HV)SvRV(self), "methods", TRUE);
	449	PPCODE:
	450	if ( ! SvRV(self) ) {
	451	die("Cannot call get_method_map as a class method");
	452	}
c94afdc4	453
c200a770	454	/* in $self->{methods} does not yet exist (or got deleted) */
	455	if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
	456	SV* new_map_ref = newRV_noinc((SV*)newHV());
	457	sv_2mortal(new_map_ref);
	458	sv_setsv(map_ref, new_map_ref);
	459	}
c94afdc4	460
c200a770	461	if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
	462	ENTER;
	463	SAVETMPS;
	464
	465	mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
	466	sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
	467
	468	FREETMPS;
	469	LEAVE;
	470	}
	471
	472	XPUSHs(map_ref);
c94afdc4	473