Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
559 lines (455 sloc) 14.1 KB
#ifndef __MOP_CLASS_C__
#define __MOP_CLASS_C__
#include "EXTERN.h"
#include "perl.h"
#include "mop.h"
#define NEED_PL_parser
#define NEED_load_module
#define NEED_sv_2pv_flags
#define NEED_vload_module
#include "ppport.h"
#define NEED_mro_get_linear_isa_GLOBAL
#include "mro_compat.h"
#define MOP_CLASS_ATTRIBUTES_DEFAULT_MAX 8
#define MOP_CLASS_METHODS_DEFAULT_MAX 4
static MGVTBL subname_vtbl;
#define KEY_FOR(x) #x
/* mop_class is a global singleton, so we can just have a typemapped
auto-generator to handle the creation of each instance.
*/
SV *
mop_class_create(char *name, size_t name_len)
{
SV *meta;
meta = mop_class_get_metaclass_by_name(name);
if (! meta) {
mop_class *klass;
Newxz(klass, 1, mop_class);
klass->state = NULL;
klass->attributes_max = MOP_CLASS_ATTRIBUTES_DEFAULT_MAX;
klass->attributes_size = 0;
Newxz(klass->attributes, klass->attributes_max, mop_attribute *);
klass->methods_max = MOP_CLASS_METHODS_DEFAULT_MAX;
klass->methods_size = 0;
Newxz(klass->methods, klass->methods_max, mop_method *);
Newxz(klass->name, name_len + 1, char);
Copy(name, klass->name, name_len + 1, char);
klass->method_map = newHV();
Copy("mop::method", klass->method_metaclass, 17, char);
meta = mop_class_associate_metaclass( klass, name );
}
return meta;
}
void
mop_class_destroy (mop_class *c)
{
int i;
if (mop_component_state_has_refs((mop_component *) c))
return;
PerlIO_printf(PerlIO_stderr(), "DESTROY mop_class %p\n", c);
mop_component_state_destroy((mop_component *) c);
for(i = 0; i < c->attributes_size; i++) {
mop_attribute_detach_from_class(c->attributes[i]);
mop_attribute_destroy(c->attributes[i]);
}
for(i = 0; i < c->methods_size; i++) {
mop_method_detach_from_class(c->methods[i]);
mop_method_destroy(c->methods[i]);
}
if (c->meta_instance) {
mop_instance_detach_from_class(c->meta_instance);
mop_instance_destroy(c->meta_instance);
}
Safefree(c->attributes);
Safefree(c->methods);
Safefree(c->name);
Safefree(c);
}
SV *
mop_class_associate_metaclass( mop_class *c, char *class )
{
SV *sv;
HV *hv;
HV *stash;
mop_state *st;
if (class == NULL) {
class = c->name;
}
stash = get_hv("mop::class::metaclass_registry", 1);
/* Create an HV-based object, and add *that* to the magic slot */
hv = newHV();
sv = newRV_noinc((SV*)hv);
(void)sv_bless(sv, gv_stashpv("mop::class", FALSE));
st = mop_state_create(c, sv);
sv_magic((SV *) hv, NULL, '~', NULL, 0);
MOP_STATE_FROM_SV(sv) = (void *) st;
if (hv_store(stash, class, strlen(class) + 1, sv, 0) == NULL) {
SvREFCNT_dec(sv);
croak("Failed to store %s in mop_metaclass_registry", class);
}
/* the hv is already at 1, but the svrv isn't */
SvREFCNT_inc(sv);
eval_pv(
SvPV_nolen(sv_2mortal(newSVpvf("sub %s::meta { mop::class::get_metaclass_by_name(Scalar::Util::blessed($_[0]) || $_[0]) }", class))),
1
);
return sv;
}
SV *
mop_class_get_metaclass_by_name( char *name )
{
HV *stash;
SV **svr;
stash = get_hv("mop::class::metaclass_registry", 1);
svr = hv_fetch(stash, name, strlen(name) + 1, 0);
if (svr == NULL || *svr == NULL) {
return NULL;
}
return newRV(SvRV(*svr));
}
void
mop_class_add_method( mop_class *c, char *subname, SV *sub )
{
char *class;
SV *sv;
HV *stash;
CV *cv;
GV *gv;
char *s;
char *end = NULL;
char saved;
char *name;
name = SvPV_nolen(sv_2mortal(newSVpvf("%s::%s", c->name, subname)));
/* Make sure the sub is a proper sub */
if (!SvROK(sub) && SvGMAGICAL(sub))
mg_get(sub);
if (SvROK(sub))
cv = (CV *) SvRV(sub);
else if (SvTYPE(sub) == SVt_PVGV)
cv = GvCVu(sub);
else if (!SvOK(sub))
croak(PL_no_usym, "a subroutine");
else if (PL_op->op_private & HINT_STRICT_REFS)
croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
cv = GvCVu(gv);
if (!cv)
croak("Undefined subroutine %s", SvPV_nolen(sub));
if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
croak("Not a subroutine reference");
for (s = name; *s++; ) {
if (*s == ':' && s[-1] == ':')
end = ++s;
else if (*s && s[-1] == '\'')
end = s;
}
s--;
if (end) {
saved = *end;
*end = 0;
stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
*end = saved;
name = end;
}
/* by fetching it rather than creating a new one, we avoid clashes */
gv = (GV *) *(hv_fetch(stash, name, s - name, TRUE ));
if (SvTYPE(gv) != SVt_PVGV) {
gv_init(gv, stash, name, s - name, GV_ADD|GV_ADDMULTI);
}
#ifndef USE_5005THREADS
if (CvPADLIST(cv)) {
/* cheap way to refcount the gv */
av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
} else
#endif
{
/* expensive way to refcount the gv */
MAGIC *mg = SvMAGIC(cv);
while (mg && mg->mg_virtual != &subname_vtbl)
mg = mg->mg_moremagic;
if (!mg) {
Newz(702, mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(cv);
mg->mg_type = PERL_MAGIC_ext;
mg->mg_virtual = &subname_vtbl;
SvMAGIC_set(cv, mg);
}
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
mg->mg_flags |= MGf_REFCOUNTED;
mg->mg_obj = (SV *) gv;
}
CvGV(cv) = gv;
sv = newRV_inc((SV *) cv);
SvSetMagicSV((SV *) gv, sv);
#if 0
sv = newRV_inc((SV *) cv);
/* Maaaybe this is no necessary if we have XS get_method_map */
if (c->methods_size == c->methods_max) {
c->methods_max *= 2;
Renew( c->methods, c->methods_max, mop_method *);
}
c->methods[ c->methods_size++ ] =
mop_method_create(subname, c->name, c, sv);
sv_dump(gv);
MOP_DEBUG("GvCVu(gv) -> ");
sv_dump(SvRV(GvCVu(gv)));
if (SvOK(gv) || !SvROK(gv) || SvTYPE(SvRV(gv)) != SVt_PVCV) {
MOP_DEBUG("OK OK");
}
#endif
MOP_DEBUG("[mop_class] add_method: adding %s to %s\n",
name, HvNAME(stash));
}
void
mop_class_remove_method( mop_class *c, char *name )
{
int i;
for(i = 0; i < c->methods_size; i++) {
mop_method *method = c->methods[i];
if (strEQ(method->name, name)) {
HE *he;
HV *stash = GvHV(gv_fetchpv(SvPV_nolen(sv_2mortal(newSVpvf("%s::", c->name))), TRUE, SVt_PVHV));
PerlIO_printf(PerlIO_stderr(), "mop_class %s removing method %s\n", c->name, name, stash);
hv_delete(stash, name, strlen(name), 0);
mop_method_detach_from_class(method);
mop_method_destroy(method);
Copy( c->methods + (i + 1), c->methods, c->methods_size - i, mop_method *);
c->methods_size--;
break;
}
}
}
void
mop_class_add_attribute(mop_class *c, mop_attribute *attr)
{
if (c->attributes_size == c->attributes_max) {
c->attributes_max *= 2;
Renew( c->attributes, c->attributes_max, mop_attribute *);
}
c->attributes[ c->attributes_size++ ] = attr;
mop_attribute_attach_to_class(attr, c);
mop_attribute_install_accessors(attr, 1);
}
void
mop_class_dump(mop_class *c)
{
int i;
PerlIO_printf(PerlIO_stderr(), "=> class %s\n", c->name);
for(i = 0; i < c->attributes_size; i++) {
mop_attribute_dump( c->attributes[i] );
}
for(i = 0; i < c->methods_size; i++) {
mop_method_dump( c->methods[i] );
}
}
void
mop_class_superclasses( mop_class *c, AV *new_isa )
{
char **list;
size_t list_size;
AV *isa;
int i;
isa = get_av( SvPV_nolen(sv_2mortal(newSVpvf("%s::ISA", c->name))), TRUE );
list_size = av_len(new_isa) + 1;
av_clear(isa);
for(i = 0; i < list_size; i++) {
SV *sv = newSV(0);
sv_setsv(sv, *(av_fetch(new_isa, i, 0)));
av_push(isa, sv);
}
}
SV *
mop_class_construct_instance(mop_class *c, HV *params)
{
mop_instance *meta_instance;
AV *linearized_isa;
SV *instance;
meta_instance = mop_class_get_meta_instance( c );
instance = mop_instance_create_instance( meta_instance );
linearized_isa = mop_class_linearized_isa( c );
{
int i;
for( i = 0; i < av_len(linearized_isa); i++) {
PerlIO_printf(PerlIO_stderr(), "i = %d, value = %s\n", i, SvPV_nolen(*(av_fetch(linearized_isa, i, 0))));
}
}
return instance;
}
mop_instance *
mop_class_get_meta_instance( mop_class *c )
{
if (c->meta_instance == NULL ) {
c->meta_instance = mop_instance_create();
mop_instance_attach_to_class( c->meta_instance, c );
}
return c->meta_instance;
}
AV *
mop_class_linearized_isa( mop_class *c )
{
return mro_get_linear_isa( gv_stashpv(c->name, 0) );
}
/* Method Map Stuff (Mostly my memo from looking at Class-MOP's XS stuff)
- methods map is stored as a hashref, but is managed in XS.
- the map is not generated until get_method_map is called.
- there's cache flag that prohibits the mop stuff from regenerating
this hash all the time
- so the most important bit is really the hash generator
*/
SV *
__mop_call0 (pTHX_ SV *const self, char *const method)
{
dSP;
SV *ret;
PUSHMARK(SP);
XPUSHs(self);
PUTBACK;
call_pv(method, G_SCALAR | G_METHOD);
SPAGAIN;
ret = POPs; PUTBACK;
return ret;
}
static bool
__mop_class_update_populate_method_map(const char *key, STRLEN keylen, SV *val, void *ud)
{
mop_class *c;
CV *cv;
char *cvpkg_name;
char *cv_name;
char *method_metaclass_name;
char *method_name;
I32 method_name_len;
SV *method_slot;
SV *method_object;
dSP;
MOP_DEBUG( "update_populate_method_map key = %s\n", key );
cv = (CV *)SvRV(val);
c = (mop_class *) ud;
if (!mop_package_get_code_info(val, &cvpkg_name, &cv_name)) {
MOP_DEBUG( "No code info for %s\n", key );
/* no code info, nothing to do */
return TRUE;
}
MOP_DEBUG("pkg = %s, name = %s\n", cvpkg_name, cv_name);
/* this checks to see that the subroutine is actually from our package */
if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
char *class_name_pv = HvNAME(gv_stashpv(c->name, 0));
if ( strNE(cvpkg_name, class_name_pv) ) {
return TRUE;
}
}
MOP_DEBUG("method name = %s\n", cv_name );
method_slot = *hv_fetch(c->method_map, cv_name, strlen(cv_name), TRUE);
if ( SvOK(method_slot) ) {
SV *const body = __mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
/* Don't need to do anything if we've already created this entry, and
they are the same
*/
if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
return TRUE;
}
}
/* optimization for default mop behavior */
if (strEQ(c->method_metaclass, "mop::method")) {
mop_method *mm;
mop_state *st;
HV *hv = newHV();
method_object = newSV(0);
mm = mop_method_create(cv_name, cvpkg_name, c, cv);
sv_setsv(method_object, sv_2mortal(newRV_noinc((SV*) hv)));
(void)sv_bless(method_object, gv_stashpv("mop::method", TRUE));
st = mop_state_create(mm, method_object);
sv_magic((SV*)hv, NULL, '~', NULL, 0);
MOP_STATE_FROM_SV(method_object) = (void *) st;
} else {
MOP_DEBUG("Shouldn't come here\n");
}
hv_store(c->method_map, cv_name, strlen(cv_name), method_object, 0);
/*
MOP_DEBUG( "mop_package_get_package_symbols %s -> %p\n", GvNAME(method_slot), method_object );
sv_setsv(method_slot, method_object);
*/
#if 0
method_metaclass_name = c->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);
mPUSHp(c->method_metaclass, strlen(c->method_metaclass)); /* invocant */
mPUSHs(newRV_inc((SV *)cv));
PUSHs(mop_associated_metaclass);
PUSHs(self);
PUSHs(KEY_FOR(package_name));
PUSHs(class_name);
PUSHs(KEY_FOR(name));
mPUSHs(newSVpv(method_name, method_name_len));
PUTBACK;
call_sv(mop_wrap, G_SCALAR | G_METHOD);
SPAGAIN;
method_object = POPs;
PUTBACK;
/* $map->{$method_name} = $method_object */
sv_setsv(method_slot, method_object);
FREETMPS;
LEAVE;
*/
#endif
}
void
mop_class_update_method_map( mop_class *c )
{
HV *const stash = gv_stashpv(c->name, 0);
mop_package_get_package_symbols(stash, TYPE_FILTER_CODE,
__mop_class_update_populate_method_map, (void *) c);
}
AV *
mop_class_get_all_methods( mop_class *c )
{
AV *isa;
AV *ret;
HV *methods;
int i;
HE *he;
isa = mop_class_linearized_isa( c );
methods = newHV();
for(i = av_len(isa); i >= 0; i--) {
mop_class *meta;
STRLEN len;
char *name;
HV *method_map;
name = SvPV(*(av_fetch(isa, i, 0)), len) ;
meta = MOP_PTR_FROM_SV(mop_class_get_metaclass_by_name( name ));
if (! meta) {
meta = MOP_PTR_FROM_SV(mop_class_create(name, len));
}
/* XXX need to understand what the cache is doing */
method_map = mop_class_get_method_map( meta );
(void) hv_iterinit(method_map);
while ( (he = hv_iternext(method_map)) ) {
hv_store_ent( methods, HeSVKEY(he), HeVAL(he), 0);
}
}
ret = newAV();
(void) hv_iterinit(methods);
while ( (he = hv_iternext(methods)) ) {
av_push( ret, HeVAL(he) );
}
return ret;
}
HV *
mop_class_get_method_map( mop_class *c )
{
mop_class_update_method_map(c);
return c->method_map;
}
#endif /* __MOP_CLASS_C__ */