From: gfx Date: Sun, 30 Aug 2009 05:18:23 +0000 (+0900) Subject: Implement a XS constructor generator X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=10c6130a613cf2b5abecb2d780d39a8a32dc7ac5;p=gitmo%2FClass-MOP.git Implement a XS constructor generator --- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 48bb7f9..deb5047 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -10,7 +10,7 @@ use Class::MOP::Method::Accessor; 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'; diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 4f3b338..8cfeaab 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -70,10 +70,10 @@ sub _new { 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; +#} # for compatibility sub bless_instance_structure { @@ -108,25 +108,25 @@ sub is_valid_slot { # 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) = @_; @@ -142,15 +142,15 @@ sub deinitialize_all_slots { } } -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) = @_; diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 4dedd49..7a37f50 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -100,11 +100,8 @@ sub initialize_body { sub _initialize_body { my $self = shift; - my $method_name = '_generate_constructor_method'; - $method_name .= '_inline' if $self->is_inline; - - $self->{'body'} = $self->$method_name; + $self->{'body'} = $self->_generate_constructor_method(); } sub generate_constructor_method { @@ -113,7 +110,22 @@ sub generate_constructor_method { 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(@_) } } diff --git a/mop.c b/mop.c index c2b5066..27309ff 100644 --- a/mop.c +++ b/mop.c @@ -223,3 +223,55 @@ mop_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){ } 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); +} diff --git a/mop.h b/mop.h index 995bdeb..7ac9de4 100644 --- a/mop.h +++ b/mop.h @@ -36,6 +36,9 @@ extern SV *mop_body; 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; @@ -76,7 +79,7 @@ HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter); /* 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); @@ -84,10 +87,11 @@ typedef struct { 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); @@ -101,14 +105,12 @@ const mop_instance_vtbl* mop_get_default_instance_vtbl(pTHX); #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 */ @@ -139,4 +141,19 @@ CV* mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSUBADDR_t const ac #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 diff --git a/t/088_xs_accessor.t b/t/088_xs_generator.t old mode 100755 new mode 100644 similarity index 59% rename from t/088_xs_accessor.t rename to t/088_xs_generator.t index e70348e..dd67d40 --- a/t/088_xs_accessor.t +++ b/t/088_xs_generator.t @@ -1,6 +1,6 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 6; use Class::MOP; use B qw(svref_2object); @@ -16,11 +16,14 @@ sub method_type{ { 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'; @@ -29,4 +32,5 @@ is method_type('Foo', 'a'), 'XS', 'accessor 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'; diff --git a/t/312_anon_class_leak.t b/t/312_anon_class_leak.t index 14ac2d3..49d2270 100644 --- a/t/312_anon_class_leak.t +++ b/t/312_anon_class_leak.t @@ -9,7 +9,7 @@ BEGIN { 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 ); @@ -24,3 +24,13 @@ leaks_cmp_ok { } '<=', $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'; diff --git a/t/314_method_leak.t b/t/314_method_leak.t index 6e97451..d6101ad 100755 --- a/t/314_method_leak.t +++ b/t/314_method_leak.t @@ -15,6 +15,7 @@ use Class::MOP; { package Foo; use metaclass; + } leaks_cmp_ok { diff --git a/xs/Class.xs b/xs/Class.xs index 38b3134..75698be 100644 --- a/xs/Class.xs +++ b/xs/Class.xs @@ -1,19 +1,5 @@ #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 PROTOTYPES: DISABLE @@ -26,6 +12,3 @@ BOOT: 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) diff --git a/xs/Instance.xs b/xs/Instance.xs index 18c9c27..9c1b5c7 100644 --- a/xs/Instance.xs +++ b/xs/Instance.xs @@ -2,15 +2,12 @@ #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 ); } @@ -68,12 +65,12 @@ mop_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot) { } 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, }; @@ -82,7 +79,6 @@ mop_get_default_instance_vtbl(pTHX){ return &mop_default_instance; } - MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance PROTOTYPES: DISABLE @@ -94,12 +90,11 @@ void* 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; } @@ -109,3 +104,58 @@ CODE: 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); diff --git a/xs/MOP.xs b/xs/MOP.xs index fc92ea3..fad2776 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -10,10 +10,12 @@ SV *mop_body; 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 @@ -100,6 +102,7 @@ EXTERN_C XS(boot_Class__MOP__Attribute); 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 @@ -116,16 +119,20 @@ BOOT: 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__Class); 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 diff --git a/xs/Method.xs b/xs/Method.xs index 90c3e9f..2c1ca0d 100644 --- a/xs/Method.xs +++ b/xs/Method.xs @@ -13,12 +13,6 @@ BOOT: 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: diff --git a/xs/MethodAccessor.xs b/xs/MethodAccessor.xs index c5b99e0..db68ad4 100644 --- a/xs/MethodAccessor.xs +++ b/xs/MethodAccessor.xs @@ -22,8 +22,8 @@ mop_accessor_get_mg(pTHX_ CV* const xsub){ 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){ @@ -35,8 +35,8 @@ mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 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) @@ -49,26 +49,20 @@ mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 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; } @@ -86,7 +80,7 @@ mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv) { */ 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; @@ -99,10 +93,10 @@ XS(mop_xs_simple_accessor) 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"); @@ -123,7 +117,7 @@ XS(mop_xs_simple_reader) 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); } @@ -137,7 +131,7 @@ XS(mop_xs_simple_writer) 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); } @@ -151,7 +145,7 @@ XS(mop_xs_simple_clearer) 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); } @@ -166,7 +160,7 @@ XS(mop_xs_simple_predicate) 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); } @@ -181,7 +175,7 @@ XS(mop_xs_simple_predicate_for_metaclass) 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); } diff --git a/xs/MethodConstructor.xs b/xs/MethodConstructor.xs new file mode 100644 index 0000000..9d9569d --- /dev/null +++ b/xs/MethodConstructor.xs @@ -0,0 +1,318 @@ +#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 +