use Class::MOP::Method::Constructor;
use Carp 'confess';
-use Scalar::Util 'blessed', 'reftype', 'weaken';
+use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
-sub create_instance {
- my $self = shift;
- bless {}, $self->_class_name;
-}
+#sub create_instance {
+# my $self = shift;
+# bless {}, $self->_class_name;
+#}
sub clone_instance {
my ($self, $instance) = @_;
# operations on created instances
-sub get_slot_value {
- my ($self, $instance, $slot_name) = @_;
- $instance->{$slot_name};
-}
-
-sub set_slot_value {
- my ($self, $instance, $slot_name, $value) = @_;
- $instance->{$slot_name} = $value;
-}
+#sub get_slot_value {
+# my ($self, $instance, $slot_name) = @_;
+# $instance->{$slot_name};
+#}
+#
+#sub set_slot_value {
+# my ($self, $instance, $slot_name, $value) = @_;
+# $instance->{$slot_name} = $value;
+#}
sub initialize_slot {
my ($self, $instance, $slot_name) = @_;
return;
}
-sub deinitialize_slot {
- my ( $self, $instance, $slot_name ) = @_;
- delete $instance->{$slot_name};
-}
+#sub deinitialize_slot {
+# my ( $self, $instance, $slot_name ) = @_;
+# delete $instance->{$slot_name};
+#}
sub initialize_all_slots {
my ($self, $instance) = @_;
}
}
-sub is_slot_initialized {
- my ($self, $instance, $slot_name, $value) = @_;
- exists $instance->{$slot_name};
-}
+#sub is_slot_initialized {
+# my ($self, $instance, $slot_name, $value) = @_;
+# exists $instance->{$slot_name};
+#}
-sub weaken_slot_value {
- my ($self, $instance, $slot_name) = @_;
- weaken $instance->{$slot_name};
-}
+#sub weaken_slot_value {
+# my ($self, $instance, $slot_name) = @_;
+# weaken $instance->{$slot_name};
+#}
sub strengthen_slot_value {
my ($self, $instance, $slot_name) = @_;
sub _initialize_body {
my $self = shift;
- my $method_name = '_generate_constructor_method';
- $method_name .= '_inline' if $self->is_inline;
+ $self->{'body'} = $self->_generate_constructor_method();
+}
+
- $self->{'body'} = $self->$method_name;
+sub generate_constructor_method {
+ Carp::cluck('The generate_constructor_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n");
+ shift->_generate_constructor_method;
}
sub _generate_constructor_method {
+ my ($self) = @_;
+
+ if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){
+ return $self->_generate_constructor_method_xs($xs);
+ }
+
+ if($self->is_inline){
+ return $self->_generate_constructor_method_inline();
+ }
+
+ return $self->_generate_constructor_method_basic();
+}
+
+sub _generate_constructor_method_basic {
return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
}
}
return NULL;
}
+
+#ifdef DEBUGGING
+SV**
+mop_av_at_safe(pTHX_ AV* const av, I32 const ix){
+ assert(av);
+ assert(SvTYPE(av) == SVt_PVAV);
+ assert(AvMAX(av) >= ix);
+ return &AvARRAY(av)[ix];
+}
+#endif
+
+
+/*
+ XXX: 5.8.1 does have shared hash key mechanism, but does not have the APIs,
+ so the following APIs, which are stolen from 5.8.9, are safe to use.
+*/
+#ifndef SvIsCOW_shared_hash
+#define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
+ (SVf_FAKE | SVf_READONLY))
+#define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
+#define SvSHARED_HASH(sv) (0 + SvUVX(sv))
+#endif
+
+SV*
+mop_newSVsv_share(pTHX_ SV* const sv){
+ STRLEN len;
+ const char* const pv = SvPV_const(sv, len);
+ U32 const hash = SvIsCOW_shared_hash(sv) ? SvSHARED_HASH(sv) : 0U;
+
+ return newSVpvn_share(pv, SvUTF8(sv) ? -len : len, hash);
+}
+
+SV*
+mop_class_of(pTHX_ SV* const sv){
+ SV* class_name;
+
+ if(IsObject(sv)){
+ HV* const stash = SvSTASH(SvRV(sv));
+ assert(stash);
+#ifdef HvNAME_HEK /* 5.10.0 */
+ assert(HvNAME_HEK(stash));
+ class_name = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
+#else
+ assert(HvNAME_get(stash));
+ class_name = sv_2mortal(newSVpv(HvNAME_get(stash), 0));
+#endif
+ }
+ else{
+ class_name = sv;
+ }
+ return mop_call1(aTHX_ mop_Class, mop_initialize, class_name);
+}
extern SV *mop_package;
extern SV *mop_package_name;
extern SV *mop_package_cache_flag;
+extern SV *mop_initialize;
+extern SV *mop_can;
+extern SV *mop_Class;
extern SV *mop_VERSION;
extern SV *mop_ISA;
/* All the MOP_mg_* macros require MAGIC* mg for the first argument */
typedef struct {
- SV* (*create_instance)(pTHX_ SV* const mi);
+ SV* (*create_instance)(pTHX_ HV* const stash);
bool (*has_slot) (pTHX_ SV* const mi, SV* const instance);
SV* (*get_slot) (pTHX_ SV* const mi, SV* const instance);
SV* (*set_slot) (pTHX_ SV* const mi, SV* const instance, SV* const value);
void (*weaken_slot) (pTHX_ SV* const mi, SV* const instance);
} mop_instance_vtbl;
-SV* mop_instance_create_instance(pTHX_ HV* const stash);
-bool mop_instance_has_slot(pTHX_ SV* const instance, SV* const slot);
-SV* mop_instance_get_slot(pTHX_ SV* const instance, SV* const slot);
-SV* mop_instance_set_slot(pTHX_ SV* const instance, SV* const slot, SV* const value);
+SV* mop_instance_create (pTHX_ HV* const stash);
+SV* mop_instance_slot (pTHX_ SV* const meta_instance, SV* const attr);
+bool mop_instance_has_slot (pTHX_ SV* const instance, SV* const slot);
+SV* mop_instance_get_slot (pTHX_ SV* const instance, SV* const slot);
+SV* mop_instance_set_slot (pTHX_ SV* const instance, SV* const slot, SV* const value);
SV* mop_instance_delete_slot(pTHX_ SV* const instance, SV* const slot);
void mop_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot);
#define MOP_mg_obj_refcounted_on(mg) (void)((mg)->mg_flags |= MGf_REFCOUNTED);
-#define MOP_mg_slot(mg) MOP_mg_obj(mg)
-
#define MOP_mg_create_instance(mg, stash) MOP_mg_vtbl(mg)->create_instance (aTHX_ (stash))
-#define MOP_mg_has_slot(mg, o) MOP_mg_vtbl(mg)->has_slot (aTHX_ (o), MOP_mg_slot(mg))
-#define MOP_mg_get_slot(mg, o) MOP_mg_vtbl(mg)->get_slot (aTHX_ (o), MOP_mg_slot(mg))
-#define MOP_mg_set_slot(mg, o, v) MOP_mg_vtbl(mg)->set_slot (aTHX_ (o), MOP_mg_slot(mg), (v))
-#define MOP_mg_delete_slot(mg, o) MOP_mg_vtbl(mg)->delete_slot (aTHX_ (o), MOP_mg_slot(mg))
-#define MOP_mg_weaken_slot(mg, o) MOP_mg_vtbl(mg)->weaken_slot (aTHX_ (o), MOP_mg_slot(mg))
+#define MOP_mg_has_slot(mg, o, slot) MOP_mg_vtbl(mg)->has_slot (aTHX_ (o), (slot))
+#define MOP_mg_get_slot(mg, o, slot) MOP_mg_vtbl(mg)->get_slot (aTHX_ (o), (slot))
+#define MOP_mg_set_slot(mg, o, slot, v) MOP_mg_vtbl(mg)->set_slot (aTHX_ (o), (slot), (v))
+#define MOP_mg_delete_slot(mg, o, slot) MOP_mg_vtbl(mg)->delete_slot (aTHX_ (o), (slot))
+#define MOP_mg_weaken_slot(mg, o, slot) MOP_mg_vtbl(mg)->weaken_slot (aTHX_ (o), (slot))
/* Class::MOP::Attribute stuff */
#define MOPf_DIE_ON_FAIL 0x01
MAGIC* mop_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags);
+
+#ifdef DEBUGGING
+#define MOP_av_at(av, ix) *mop_av_at_safe(aTHX_ (av) , (ix))
+SV** mop_av_at_safe(pTHX_ AV* const mi, I32 const ix);
+#else
+#define MOP_av_at(av, ix) AvARRAY(av)[ix]
+#endif
+
+#define IsObject(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)))
+
+#define newSVsv_share(sv) mop_newSVsv_share(aTHX_ sv)
+SV* mop_newSVsv_share(pTHX_ SV*);
+
+SV* mop_class_of(pTHX_ SV* const sv);
+
#endif
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 6;
use Class::MOP;
use B qw(svref_2object);
{
package Foo;
use metaclass;
- __PACKAGE__->meta->add_attribute('r' => (reader => 'r'));
- __PACKAGE__->meta->add_attribute('w' => (writer => 'w'));
- __PACKAGE__->meta->add_attribute('a' => (accessor => 'a'));
- __PACKAGE__->meta->add_attribute('c' => (clearer => 'c'));
- __PACKAGE__->meta->add_attribute('p' => (predicate => 'p'));
+ my $meta = __PACKAGE__->meta;
+ $meta->add_attribute('r' => (reader => 'r'));
+ $meta->add_attribute('w' => (writer => 'w'));
+ $meta->add_attribute('a' => (accessor => 'a'));
+ $meta->add_attribute('c' => (clearer => 'c'));
+ $meta->add_attribute('p' => (predicate => 'p'));
+
+ $meta->make_immutable();
}
is method_type('Foo', 'r'), 'XS', 'reader is XS';
is method_type('Foo', 'c'), 'XS', 'clearer is XS';
is method_type('Foo', 'p'), 'XS', 'predicate is XS';
+is method_type('Foo', 'new'), 'XS', 'constructor is XS';
plan skip_all => "Test::LeakTrace is required for this test" if $@;
}
-plan tests => 2;
+plan tests => 4;
# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV.
my $expected = ( $] == 5.010_000 ? 1 : 0 );
}
'<=', $expected, 'create_anon_class(superclass => [...])';
+leaks_cmp_ok {
+ Class::MOP::Class->create_anon_class()->new_object();
+}
+'<=', $expected, 'create_anon_class->new_object';
+
+leaks_cmp_ok {
+ my $meta = Class::MOP::Class->create_anon_class();
+ $meta->make_immutable();
+}
+'<=', $expected, 'create_anon_class->make_immutable';
{
package Foo;
use metaclass;
+
}
leaks_cmp_ok {
#include "mop.h"
-#define _generate_constructor_method_xs(self, vtbl) mop_generate_constructor_method_xs(aTHX_ self, (mop_instance_vtbl*)vtbl)
-
-static MGVTBL mop_constructor_vtbl;
-
-static CV*
-mop_generate_constructor_method_xs(pTHX_ SV* const metaclass, mop_instance_vtbl* const instance_vtbl){
- // CV* const xsub = newXS(NULL, mop_xs_constructor, __FILE__);
-
- assert(instance_vtbl);
-
-}
MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class
INSTALL_SIMPLE_READER(Class, constructor_name);
INSTALL_SIMPLE_READER(Class, constructor_class);
INSTALL_SIMPLE_READER(Class, destructor_class);
-
-CV*
-_generate_constructor_method_xs(SV* self, void* instance_vtbl)
#define CHECK_INSTANCE(instance) STMT_START{ \
if(!(SvROK(instance) && SvTYPE(SvRV(instance)) == SVt_PVHV)){ \
- croak("Invalid object"); \
- } \
- if(SvTIED_mg(SvRV(instance), PERL_MAGIC_tied)){ \
- croak("MOP::Instance: tied HASH is not yet supported"); \
+ croak("Invalid object for instance managers"); \
} \
} STMT_END
SV*
-mop_instance_create_instance(pTHX_ HV* const stash) {
+mop_instance_create(pTHX_ HV* const stash) {
assert(stash);
return sv_bless( newRV_noinc((SV*)newHV()), stash );
}
}
static const mop_instance_vtbl mop_default_instance = {
- mop_instance_create_instance,
- mop_instance_has_slot,
- mop_instance_get_slot,
- mop_instance_set_slot,
- mop_instance_delete_slot,
- mop_instance_weaken_slot,
+ mop_instance_create,
+ mop_instance_has_slot,
+ mop_instance_get_slot,
+ mop_instance_set_slot,
+ mop_instance_delete_slot,
+ mop_instance_weaken_slot,
};
return &mop_default_instance;
}
-
MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance
PROTOTYPES: DISABLE
can_xs(SV* self)
PREINIT:
CV* const default_method = get_cv("Class::MOP::Instance::get_slot_value", FALSE);
- SV* const can = newSVpvs_flags("can", SVs_TEMP);
SV* const method = newSVpvs_flags("get_slot_value", SVs_TEMP);
SV* code_ref;
CODE:
/* $self->can("get_slot_value") == \&Class::MOP::Instance::get_slot_value */
- code_ref = mop_call1(aTHX_ self, can, method);
+ code_ref = mop_call1(aTHX_ self, mop_can, method);
if(SvROK(code_ref) && SvRV(code_ref) == (SV*)default_method){
RETVAL = (void*)&mop_default_instance;
}
OUTPUT:
RETVAL
+SV*
+create_instance(SV* self)
+PREINIT:
+ SV* class_name;
+CODE:
+ class_name = mop_call0_pvs(self, "_class_name");
+ RETVAL = mop_instance_create(aTHX_ gv_stashsv(class_name, TRUE));
+OUTPUT:
+ RETVAL
+
+bool
+is_slot_initialized(SV* self, SV* instance, SV* slot)
+CODE:
+ PERL_UNUSED_VAR(self);
+ RETVAL = mop_instance_has_slot(aTHX_ instance, slot);
+OUTPUT:
+ RETVAL
+
+SV*
+get_slot_value(SV* self, SV* instance, SV* slot)
+CODE:
+ PERL_UNUSED_VAR(self);
+ RETVAL = mop_instance_get_slot(aTHX_ instance, slot);
+ RETVAL = RETVAL ? newSVsv(RETVAL) : &PL_sv_undef;
+OUTPUT:
+ RETVAL
+
+SV*
+set_slot_value(SV* self, SV* instance, SV* slot, SV* value)
+CODE:
+ PERL_UNUSED_VAR(self);
+ RETVAL = mop_instance_set_slot(aTHX_ instance, slot, value);
+ SvREFCNT_inc_simple_void_NN(RETVAL);
+OUTPUT:
+ RETVAL
+
+SV*
+deinitialize_slot(SV* self, SV* instance, SV* slot)
+CODE:
+ PERL_UNUSED_VAR(self);
+ RETVAL = mop_instance_delete_slot(aTHX_ instance, slot);
+ if(RETVAL){
+ SvREFCNT_inc_simple_void_NN(RETVAL);
+ }
+ else{
+ RETVAL = &PL_sv_undef;
+ }
+OUTPUT:
+ RETVAL
+
+void
+weaken_slot_value(SV* self, SV* instance, SV* slot)
+CODE:
+ PERL_UNUSED_VAR(self);
+ mop_instance_weaken_slot(aTHX_ instance, slot);
SV *mop_package;
SV *mop_package_name;
SV *mop_package_cache_flag;
-
+SV *mop_initialize;
+SV *mop_isa;
+SV *mop_can;
+SV *mop_Class;
SV *mop_VERSION;
SV *mop_ISA;
-SV *mop_isa;
/* equivalent to "blessed($x) && $x->isa($klass)" */
bool
EXTERN_C XS(boot_Class__MOP__Method);
EXTERN_C XS(boot_Class__MOP__Instance);
EXTERN_C XS(boot_Class__MOP__Method__Accessor);
+EXTERN_C XS(boot_Class__MOP__Method__Constructor);
MODULE = Class::MOP PACKAGE = Class::MOP
mop_package = MAKE_KEYSV(package);
mop_package_name = MAKE_KEYSV(package_name);
mop_package_cache_flag = MAKE_KEYSV(_package_cache_flag);
+ mop_initialize = MAKE_KEYSV(initialize);
+ mop_Class = MAKE_KEYSV(Class::MOP::Class);
mop_VERSION = MAKE_KEYSV(VERSION);
mop_ISA = MAKE_KEYSV(ISA);
mop_isa = MAKE_KEYSV(isa);
+ mop_can = MAKE_KEYSV(can);
MOP_CALL_BOOT (boot_Class__MOP__Package);
MOP_CALL_BOOT (boot_Class__MOP__Attribute);
- MOP_CALL_BOOT (boot_Class__MOP__Method);
MOP_CALL_BOOT (boot_Class__MOP__Instance);
+ MOP_CALL_BOOT (boot_Class__MOP__Method);
MOP_CALL_BOOT (boot_Class__MOP__Method__Accessor);
+ MOP_CALL_BOOT (boot_Class__MOP__Method__Constructor);
# use prototype here to be compatible with get_code_info from Sub::Identify
void
INSTALL_SIMPLE_WRITER_WITH_KEY(Method, _set_original_method, original_method);
-MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method::Constructor
-
-BOOT:
- INSTALL_SIMPLE_READER(Method::Constructor, options);
- INSTALL_SIMPLE_READER(Method::Constructor, associated_metaclass);
-
MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method::Generated
BOOT:
CV*
mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSUBADDR_t const accessor_impl, const mop_instance_vtbl* vtbl){
- CV* const xsub = newXS((char*)fq_name, accessor_impl, __FILE__);
- SV* const keysv = newSVpvn_share(key, keylen, 0U);
+ CV* const xsub = newXS((char*)fq_name, accessor_impl, __FILE__);
+ SV* const slot = newSVpvn_share(key, keylen, 0U);
MAGIC* mg;
if(!vtbl){
sv_2mortal((SV*)xsub);
}
- mg = sv_magicext((SV*)xsub, keysv, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
- SvREFCNT_dec(keysv); /* sv_magicext() increases refcnt in mg_obj */
+ mg = sv_magicext((SV*)xsub, slot, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
+ SvREFCNT_dec(slot); /* sv_magicext() increases refcnt in mg_obj */
/* NOTE:
* although we use MAGIC for gc, we also store mg to CvXSUBANY slot for efficiency (gfx)
CV*
mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSUBADDR_t const accessor_impl, mop_instance_vtbl* const vtbl){
- /* $key = $accessor->associated_attribute->name */
+ /* $slot = $accessor->associated_attribute->name */
SV* const attr = mop_call0(aTHX_ accessor, mop_associated_attribute);
- SV* const key = mop_call0(aTHX_ attr, mop_name);
-
- STRLEN klen;
- const char* const kpv = SvPV_const(key, klen);
- SV* const keysv = newSVpvn_share(kpv, klen, 0U);
-
- MAGIC* mg;
-
+ SV* const slot = newSVsv_share(mop_call0(aTHX_ attr, mop_name));
CV* const xsub = newXS(NULL, accessor_impl, __FILE__);
+ MAGIC* mg;
sv_2mortal((SV*)xsub);
- mg = sv_magicext((SV*)xsub, keysv, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
- SvREFCNT_dec(keysv); /* sv_magicext() increases refcnt in mg_obj */
+ mg = sv_magicext((SV*)xsub, slot, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
+ SvREFCNT_dec(slot); /* sv_magicext() increases refcnt in mg_obj */
/* NOTE:
* although we use MAGIC for gc, we also store mg to CvXSUBANY slot for efficiency (gfx)
*/
- CvXSUBANY(xsub).any_ptr = mg;
+ CvXSUBANY(xsub).any_ptr = (void*)mg;
return xsub;
}
*/
self = ST(0);
- if(!(SvROK(self) && SvOBJECT(SvRV(self)))){
+ if(!IsObject(self)){
croak("cant call %s as a class method", GvNAME(CvGV(cv)));
}
return self;
SV* value;
if(items == 1){ /* reader */
- value = MOP_mg_get_slot(mg, self);
+ value = MOP_mg_get_slot(mg, self, MOP_mg_obj(mg));
}
else if (items == 2){ /* writer */
- value = MOP_mg_set_slot(mg, self, ST(1));
+ value = MOP_mg_set_slot(mg, self, MOP_mg_obj(mg), ST(1));
}
else{
croak("expected exactly one or two argument");
croak("expected exactly one argument");
}
- value = MOP_mg_get_slot(mg, self);
+ value = MOP_mg_get_slot(mg, self, MOP_mg_obj(mg));
ST(0) = value ? value : &PL_sv_undef;
XSRETURN(1);
}
croak("expected exactly two argument");
}
- ST(0) = MOP_mg_set_slot(mg, self, ST(1));
+ ST(0) = MOP_mg_set_slot(mg, self, MOP_mg_obj(mg), ST(1));
XSRETURN(1);
}
croak("expected exactly one argument");
}
- value = MOP_mg_delete_slot(mg, self);
+ value = MOP_mg_delete_slot(mg, self, MOP_mg_obj(mg));
ST(0) = value ? value : &PL_sv_undef;
XSRETURN(1);
}
croak("expected exactly one argument");
}
- ST(0) = boolSV( MOP_mg_has_slot(mg, self) );
+ ST(0) = boolSV( MOP_mg_has_slot(mg, self, MOP_mg_obj(mg)) );
XSRETURN(1);
}
croak("expected exactly one argument");
}
- value = MOP_mg_get_slot(mg, self);
+ value = MOP_mg_get_slot(mg, self, MOP_mg_obj(mg));
ST(0) = boolSV( value && SvOK(value ));
XSRETURN(1);
}
--- /dev/null
+#include "mop.h"
+
+
+static MGVTBL mop_attr_vtbl;
+
+#define MOP_attr_slot(meta) MOP_av_at(meta, MOP_ATTR_SLOT)
+#define MOP_attr_init_arg(meta) MOP_av_at(meta, MOP_ATTR_INIT_ARG)
+#define MOP_attr_default(meta) MOP_av_at(meta, MOP_ATTR_DEFAULT)
+#define MOP_attr_builder(meta) MOP_av_at(meta, MOP_ATTR_BUILDER)
+
+enum mop_attr_ix_t{
+ MOP_ATTR_SLOT,
+
+ MOP_ATTR_INIT_ARG,
+ MOP_ATTR_DEFAULT,
+ MOP_ATTR_BUILDER,
+
+ MOP_ATTR_last,
+};
+
+enum mop_attr_flags_t{ /* must be 16 bits */
+ MOP_ATTRf_HAS_INIT_ARG = 0x0001,
+ MOP_ATTRf_HAS_DEFAULT = 0x0002,
+ MOP_ATTRf_IS_DEFAULT_A_CODEREF = 0x0004,
+ MOP_ATTRf_HAS_BUILDER = 0x0008,
+ MOP_ATTRf_HAS_INITIALIZER = 0x0010,
+
+
+ MOP_ATTRf_DEBUG = 0x8000
+};
+
+static MAGIC*
+mop_attr_mg(pTHX_ SV* const attr, SV* const instance){
+ MAGIC* mg;
+
+ if(!IsObject(attr)) {
+ croak("Invalid Attribute object");
+ }
+
+ /* attribute mg:
+ mg_obj: meta information (AV*)
+ mg_ptr: meta instance virtual table (mop_instance_vtbl*)
+ */
+
+ if(!(SvMAGICAL(SvRV(attr)) && (mg = mop_mg_find(aTHX_ SvRV(attr), &mop_attr_vtbl, 0))) ) {
+ U16 flags = 0;
+ AV* const meta = newAV();
+ SV* name;
+ SV* sv;
+
+ mg = sv_magicext(SvRV(attr), (SV*)meta, PERL_MAGIC_ext, &mop_attr_vtbl, NULL, 0);
+ SvREFCNT_dec(meta);
+ av_extend(meta, MOP_ATTR_last - 1);
+
+ ENTER;
+ SAVETMPS;
+
+ name = mop_call0(aTHX_ attr, mop_name);
+ av_store(meta, MOP_ATTR_SLOT, newSVsv_share(name));
+
+ if(SvOK( sv = mop_call0_pvs(attr, "init_arg") )) {
+ flags |= MOP_ATTRf_HAS_INIT_ARG;
+
+ av_store(meta, MOP_ATTR_INIT_ARG, newSVsv_share(sv));
+ }
+
+ /* NOTE: Setting both default and builder is not allowed */
+ if(SvOK( sv = mop_call0_pvs(attr, "builder") )) {
+ SV* const builder = sv;
+ flags |= MOP_ATTRf_HAS_BUILDER;
+
+ if(SvOK( sv = mop_call1(aTHX_ instance, mop_can, builder) )){
+ av_store(meta, MOP_ATTR_BUILDER, newSVsv(sv));
+ }
+ else{
+ croak("%s does not support builder method '%"SVf"' for attribute '%"SVf"'",
+ sv_reftype(SvRV(instance), TRUE), builder, name);
+ }
+ }
+ else if(SvOK( sv = mop_call0_pvs(attr, "default") )) {
+ if(SvTRUEx( mop_call0_pvs(attr, "is_default_a_coderef") )){
+ flags |= MOP_ATTRf_HAS_BUILDER;
+ av_store(meta, MOP_ATTR_BUILDER, newSVsv(sv));
+ }
+ else {
+ flags |= MOP_ATTRf_HAS_DEFAULT;
+ av_store(meta, MOP_ATTR_DEFAULT, newSVsv(sv));
+ }
+ }
+
+ MOP_mg_flags(mg) = flags;
+
+ if(flags & MOP_ATTRf_DEBUG) {
+ warn("%s: setup attr_mg for '%"SVf"'\n", sv_reftype(SvRV(instance), TRUE), name);
+ }
+
+ FREETMPS;
+ LEAVE;
+ }
+
+ return mg;
+}
+
+static MGVTBL mop_constructor_vtbl;
+
+static HV*
+mop_build_args(pTHX_ CV* const cv, I32 const ax, I32 const items){
+ HV* args;
+ if(items == 1){
+ SV* const sv = ST(0);
+ SvGETMAGIC(sv);
+ if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)){
+ croak("Single arguments to %s() must be a HASH ref", GvNAME(CvGV(cv)));
+ }
+ args = (HV*)SvRV(sv);
+ }
+ else{
+ I32 i;
+
+ if( items % 2 ){
+ croak("Odd number of arguments for %s()", GvNAME(CvGV(cv)));
+ }
+
+ args = newHV();
+ sv_2mortal((SV*)args);
+
+ for(i = 0; i < items; i += 2){
+ SV* const key = ST(i);
+ SV* const value = ST(i+1);
+ (void)hv_store_ent(args, key, value, 0U);
+ SvREFCNT_inc_simple_void_NN(value);
+ }
+ }
+ return args;
+}
+
+static void
+mop_attr_initialize_instance_slot(pTHX_ SV* const attr, const mop_instance_vtbl* const vtbl, SV* const instance, HV* const args){
+ MAGIC* const mg = mop_attr_mg(aTHX_ attr, instance);
+ AV* const meta = (AV*)MOP_mg_obj(mg);
+ U16 const flags = MOP_mg_flags(mg);
+ HE* arg;
+ SV* value;
+
+ if(flags & MOP_ATTRf_DEBUG){
+ warn("%s: initialize_instance_slot '%"SVf"' (0x%04x)\n", sv_reftype(SvRV(instance), TRUE), MOP_attr_slot(meta), (unsigned)flags);
+ }
+
+ if( flags & MOP_ATTRf_HAS_INIT_ARG && (arg = hv_fetch_ent(args, MOP_attr_init_arg(meta), FALSE, 0U)) ){
+ value = hv_iterval(args, arg);
+ }
+ else if(flags & MOP_ATTRf_HAS_DEFAULT) {
+ value = MOP_attr_default(meta); /* it's always a non-ref value */
+ }
+ else if(flags & MOP_ATTRf_HAS_BUILDER) {
+ SV* const builder = MOP_attr_builder(meta); /* code-ref default value or builder */
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(instance);
+ PUTBACK;
+
+ call_sv(builder, G_SCALAR);
+
+ SPAGAIN;
+ value = POPs;
+ SvREFCNT_inc_simple_void_NN(value);
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+
+ sv_2mortal(value);
+ }
+ else{
+ value = NULL;
+ }
+
+ if(value){
+ if(flags & MOP_ATTRf_HAS_INITIALIZER){
+ /* $attr->set_initial_value($meta_instance, $instance, $value) */
+ dSP;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 4);
+ PUSHs(attr);
+ PUSHs(instance);
+ mPUSHs(value);
+ PUTBACK;
+
+ call_method("set_initial_value", G_VOID | G_DISCARD);
+ }
+ else{
+ vtbl->set_slot(aTHX_ instance, MOP_attr_slot(meta), value);
+ }
+ }
+}
+
+static AV*
+mop_class_get_all_attributes(pTHX_ SV* const metaclass){
+ AV* const attrs = newAV();
+ dSP;
+ I32 n;
+
+ PUSHMARK(SP);
+ XPUSHs(metaclass);
+ PUTBACK;
+
+ n = call_method("get_all_attributes", G_ARRAY);
+ SPAGAIN;
+
+ if(n){
+ av_extend(attrs, n - 1);
+ while(n){
+ (void)av_store(attrs, --n, newSVsv(POPs));
+ }
+ }
+
+ PUTBACK;
+
+ return attrs;
+}
+
+XS(mop_xs_constructor);
+XS(mop_xs_constructor)
+{
+ dVAR; dXSARGS;
+ dMOP_mg(cv);
+ AV* const attrs = (AV*)MOP_mg_obj(mg);
+ SV* klass;
+ HV* stash;
+ SV* instance;
+ I32 i;
+ I32 len;
+ HV* args;
+
+ assert(SvTYPE(attrs) == SVt_PVAV);
+
+ if(items < 0){
+ croak("Not enough arguments for %s()", GvNAME(CvGV(cv)));
+ }
+
+ klass = ST(0);
+
+ if(SvROK(klass)){
+ croak("The constructor must be called as a class method");
+ }
+
+ stash = gv_stashsv(klass, TRUE);
+
+ args = mop_build_args(aTHX_ cv, ax+1, items-1);
+
+ if( stash != GvSTASH(CvGV(cv)) ){
+ SV* const metaclass = mop_class_of(aTHX_ klass);
+ dSP;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(metaclass);
+ mPUSHs(newRV_inc((SV*)args));
+ PUTBACK;
+
+ call_method("new_object", GIMME_V);
+ return;
+ }
+
+ instance = sv_2mortal( MOP_mg_create_instance(mg, stash) );
+ if(!IsObject(instance)){
+ croak("create_instance() did not return an object instance");
+ }
+
+ len = AvFILLp(attrs) + 1;
+ for(i = 0; i < len; i++){
+ mop_attr_initialize_instance_slot(aTHX_ AvARRAY(attrs)[i], MOP_mg_vtbl(mg), instance, args);
+ }
+
+ ST(0) = instance;
+ XSRETURN(1);
+}
+
+
+static CV*
+mop_generate_constructor_method_xs(pTHX_ SV* const constructor, mop_instance_vtbl* const vtbl){
+ SV* const metaclass = mop_call0(aTHX_ constructor, mop_associated_metaclass);
+
+ CV* const xsub = newXS(NULL, mop_xs_constructor, __FILE__);
+ MAGIC* mg;
+ AV* attrs;
+
+ sv_2mortal((SV*)xsub);
+
+ attrs = mop_class_get_all_attributes(aTHX_ metaclass);
+ mg = sv_magicext((SV*)xsub, (SV*)attrs, PERL_MAGIC_ext, &mop_constructor_vtbl, (char*)vtbl, 0);
+ SvREFCNT_dec(attrs);
+ CvXSUBANY(xsub).any_ptr = (void*)mg;
+
+ return xsub;
+}
+
+
+MODULE = Class::MOP::Method::Constructor PACKAGE = Class::MOP::Method::Constructor
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Method::Constructor, options);
+ INSTALL_SIMPLE_READER(Method::Constructor, associated_metaclass);
+
+CV*
+_generate_constructor_method_xs(SV* self, void* instance_vtbl)
+CODE:
+ RETVAL = mop_generate_constructor_method_xs(aTHX_ self, instance_vtbl);
+OUTPUT:
+ RETVAL
+
projects / gitmo/Class-MOP.git / commitdiff