Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
128 lines (99 sloc) 3.01 KB
#ifndef __MOP_ATTRIBUTE_C__
#define __MOP_ATTRIBUTE_C__
#include "mop.h"
mop_attribute *
mop_attribute_create( char *name, char *accessor, char *reader, char *writer, char *predicate, char *clearer, char *builder, char *init_arg, SV *default_value, mop_class *associated_metaclass) {
mop_attribute *attr;
Newxz(attr, 1, mop_attribute);
if (name == NULL)
croak("Attribute name cannot be NULL");
{ /* name */
size_t len = strlen(name);
Newxz(attr->name, len + 1, char);
Copy(name, attr->name, len + 1, char);
}
if (accessor == NULL)
accessor = name;
{ /* accessor */
size_t len = strlen(accessor);
Newxz(attr->accessor, len + 1, char);
Copy(accessor, attr->accessor, len + 1, char);
}
return attr;
}
void
mop_attribute_destroy( mop_attribute *attr )
{
if (mop_component_state_has_refs((mop_component *) attr))
return;
mop_component_state_destroy((mop_component *) attr );
if (attr->associated_metaclass) {
/* if it has an associated class, then it will have to live through */
return;
}
PerlIO_printf(PerlIO_stderr(), " DESTROY mop_attribute %p\n", attr);
Safefree(attr->name);
Safefree(attr->accessor);
Safefree(attr);
}
char *
mop_attribute_name( mop_attribute *mop_a ) {
return mop_a->name;
}
void
mop_attribute_attach_to_class ( mop_attribute *attr, mop_class *c )
{
attr->associated_metaclass = c;
}
void
mop_attribute_detach_from_class ( mop_attribute *attr )
{
attr->associated_metaclass = NULL;
}
void
mop_attribute_install_accessors( mop_attribute *mop_a, bool inlined )
{
/* if we have a accessor metaclass, let perl handle. otherwise,
use the C based optimized version
*/
if (mop_a->accessor_metaclass)
croak("Custom accessor metaclass handling is unimplemented");
/* k. call directly to the accessor producing functions */
if (mop_a->accessor != NULL) {
mop_class_add_method(
mop_a->associated_metaclass,
mop_a->accessor,
mop_attribute_create_accessor( mop_a, inlined )
);
}
}
SV *
mop_attribute_create_accessor(mop_attribute *attr, bool inlined)
{
/* XXX - I believe this portion gains nothing by using XS? */
SV *sv = newSV(0);
sv_setpv(sv, "sub {");
sv_2mortal(sv);
/* XXX - Implement real instance metaclass stuff later */
if (strlen(attr->associated_metaclass->instance_metaclass) > 0) {
croak("instance_metaclass not implemented");
}
mop_instance_inline_set_slot_value( sv, "$_[0]", attr->name, "$_[1]" );
sv_catpvf(sv, " if scalar(@_) == 2; ");
mop_instance_inline_get_slot_value( sv, "$_[0]", attr->name );
sv_catpvf(sv, "}");
{
dSP;
eval_sv(sv , G_EVAL | G_SCALAR);
SPAGAIN;
sv = POPs;
PUTBACK;
}
return sv;
}
void
mop_attribute_dump( mop_attribute *attr )
{
PerlIO_printf(PerlIO_stderr(), " -> attribute %s\n", attr->name);
}
#endif /* __MOP_ATTRIBUTE_C__ */