From: gfx Date: Tue, 18 Aug 2009 04:29:52 +0000 (+0900) Subject: A first step to cooperate Moose.xs (topic/xs-accessor) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e989c0dfb76585f18a541c6f18c2dfc931b67326;p=gitmo%2FClass-MOP.git A first step to cooperate Moose.xs (topic/xs-accessor) --- diff --git a/Makefile.PL b/Makefile.PL index a872582..c79c4ca 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -25,7 +25,9 @@ test_requires 'File::Spec'; test_requires 'Test::More' => '0.88'; test_requires 'Test::Exception' => '0.27'; -extra_tests(); +install_headers('mop.h'); + +#extra_tests(); makemaker_args( CCFLAGS => $ccflags ); diff --git a/bench/foo.pl b/bench/foo.pl old mode 100755 new mode 100644 diff --git a/bench/loading-benchmark.pl b/bench/loading-benchmark.pl old mode 100755 new mode 100644 diff --git a/bench/profile.pl b/bench/profile.pl old mode 100755 new mode 100644 diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index ba8b14d..179c7b6 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -29,9 +29,11 @@ our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -require XSLoader; -XSLoader::load( __PACKAGE__, $XS_VERSION ); - +{ + require DynaLoader; + local *dl_load_flags = sub{ 0x01 }; + DynaLoader::bootstrap_inherit( __PACKAGE__, $XS_VERSION ); +} { # Metaclasses are singletons, so we cache them here. diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index bc1defb..1a7ca1f 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -393,6 +393,18 @@ into, and returns code to rebless an instance into a class. =back +=head2 XS Instance Operations + +=over 4 + +=item B<< $metainstance->can_xs() >> + +This is an integer that indicates the address of XS virtual table for slot accesses. +By default it returns a virtual table address to operate hash references, but subclasses +should override this. + +=back + =head2 Introspection =over 4 diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 6353314..80bb79e 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -74,17 +74,6 @@ sub _new { #sub accessor_type { (shift)->{'accessor_type'} } -sub can_xs { - my($self, $method_name) = @_; - # don't use $method_name here, but there may be cases it is required. - - # FIXME: I didn't know how to detect it properly (gfx) - return ref($self) eq __PACKAGE__ - && $self->associated_attribute->associated_class->instance_metaclass eq 'Class::MOP::Instance'; -} - -sub attribute_name{ (shift)->associated_attribute->name } - ## factory sub _initialize_body { @@ -93,19 +82,95 @@ sub _initialize_body { my $method_name = join "_" => ( '_generate', $self->accessor_type, - 'method' + 'method', ); - if($self->is_inline){ - $method_name .= $self->can_xs($method_name) ? '_xs' : '_inline'; - } - $self->{'body'} = $self->$method_name(); + return; } ## generators sub _generate_accessor_method { + my ($self) = @_; + + if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){ + return $self->_generate_accessor_method_xs($xs); + } + + if($self->is_inline){ + return $self->_generate_accessor_method_inline(); + } + + return $self->_generate_accessor_method_basic(); +} + +sub _generate_reader_method { + my ($self) = @_; + + if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){ + return $self->_generate_reader_method_xs($xs); + } + + if($self->is_inline){ + return $self->_generate_reader_method_inline(); + } + + return $self->_generate_reader_method_basic(); +} + +sub _generate_writer_method { + my ($self) = @_; + + if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){ + return $self->_generate_writer_method_xs($xs); + } + + if($self->is_inline){ + return $self->_generate_writer_method_inline(); + } + + return $self->_generate_writer_method_basic(); +} + +sub _generate_clearer_method { + my ($self) = @_; + + if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){ + return $self->_generate_clearer_method_xs($xs); + } + + if($self->is_inline){ + return $self->_generate_clearer_method_inline(); + } + + return $self->_generate_clearer_method_basic(); +} + +sub _generate_predicate_method { + my ($self) = @_; + + if(my $xs = $self->associated_metaclass->instance_metaclass->can_xs()){ + return $self->_generate_predicate_method_xs($xs); + } + + if($self->is_inline){ + return $self->_generate_predicate_method_inline(); + } + + return $self->_generate_predicate_method_basic(); +} + + +## basic generators + +sub generate_accessor_method { + Carp::cluck('The generate_accessor_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_accessor_method_basic; +} + +sub _generate_accessor_method_basic { my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; @@ -113,7 +178,13 @@ sub _generate_accessor_method { }; } -sub _generate_reader_method { +sub generate_reader_method { + Carp::cluck('The generate_reader_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_reader_method_basic; +} + +sub _generate_reader_method_basic { my $attr = (shift)->associated_attribute; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; @@ -121,22 +192,39 @@ sub _generate_reader_method { }; } +sub generate_writer_method { + Carp::cluck('The generate_writer_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_writer_method_basic; +} -sub _generate_writer_method { +sub _generate_writer_method_basic { my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]); }; } -sub _generate_predicate_method { +sub generate_predicate_method { + Carp::cluck('The generate_predicate_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_predicate_method_basic; +} + +sub _generate_predicate_method_basic { my $attr = (shift)->associated_attribute; return sub { $attr->has_value($_[0]) }; } -sub _generate_clearer_method { +sub generate_clearer_method { + Carp::cluck('The generate_clearer_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_clearer_method_basic; +} + +sub _generate_clearer_method_basic { my $attr = (shift)->associated_attribute; return sub { $attr->clear_value($_[0]) diff --git a/mop.c b/mop.c index cc10714..73732b5 100644 --- a/mop.c +++ b/mop.c @@ -75,6 +75,28 @@ mop_call0 (pTHX_ SV *const self, SV *const method) return ret; } +SV * +mop_call1 (pTHX_ SV *const self, SV *const method, SV* const arg1) +{ + dSP; + SV *ret; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(self); + PUSHs(arg1); + PUTBACK; + + call_sv(method, G_SCALAR | G_METHOD); + + SPAGAIN; + ret = POPs; + PUTBACK; + + return ret; +} + + int mop_get_code_info (SV *coderef, char **pkg, char **name) { @@ -109,6 +131,7 @@ mop_get_code_info (SV *coderef, char **pkg, char **name) void mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) { + dTHX; HE *he; (void)hv_iterinit(stash); @@ -160,6 +183,7 @@ mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb static bool collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) { + dTHX; HV *hash = (HV *)ud; if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) { @@ -172,165 +196,26 @@ collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) HV * mop_get_all_package_symbols (HV *stash, type_filter_t filter) { + dTHX; HV *ret = newHV (); mop_get_package_symbols (stash, filter, collect_all_symbols, ret); return ret; } -static MGVTBL mop_accessor_vtbl; /* the MAGIC identity */ - -CV* -mop_install_simple_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(accessor_impl)){ - CV* const xsub = newXS((char*)fq_name, accessor_impl, __FILE__); - SV* const keysv = newSVpvn_share(key, keylen, 0U); - sv_magicext((SV*)xsub, keysv, PERL_MAGIC_ext, &mop_accessor_vtbl, NULL, 0); - SvREFCNT_dec(keysv); /* sv_magicext() increases refcnt in mg_obj */ - return xsub; -} - -static MAGIC* -mop_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){ +MAGIC* +mop_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){ MAGIC* mg; assert(sv != NULL); for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){ if(mg->mg_virtual == vtbl){ - break; + return mg; } } - return mg; -} -static SV* -mop_fetch_attr(pTHX_ SV* const self, SV* const key, I32 const create, CV* const cv){ - HE* he; - if (!SvROK(self)) { - croak("can't call %s as a class method", GvNAME(CvGV(cv))); - } - if (SvTYPE(SvRV(self)) != SVt_PVHV) { - croak("object is not a hashref"); - } - if((he = hv_fetch_ent((HV*)SvRV(self), key, create, 0U))){ - return HeVAL(he); + if(flags & MOPf_DIE_ON_FAIL){ + croak("mop_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv))); } return NULL; } -static SV* -mop_delete_attr(pTHX_ SV* const self, SV* const key, CV* const cv){ - SV* sv; - if (!SvROK(self)) { - croak("can't call %s as a class method", GvNAME(CvGV(cv))); - } - if (SvTYPE(SvRV(self)) != SVt_PVHV) { - croak("object is not a hashref"); - } - if((sv = hv_delete_ent((HV*)SvRV(self), key, 0, 0U))){ - return sv; - } - return NULL; -} - -XS(mop_xs_simple_accessor) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - if(items == 1){ /* reader */ - attr = mop_fetch_attr(aTHX_ ST(0), key, FALSE, cv); - } - else if (items == 2){ /* writer */ - attr = mop_fetch_attr(aTHX_ ST(0), key, TRUE, cv); - sv_setsv(attr, ST(1)); - } - else{ - croak("expected exactly one or two argument"); - } - ST(0) = attr ? attr : &PL_sv_undef; - XSRETURN(1); -} - - -XS(mop_xs_simple_reader) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - - if (items != 1) { - croak("expected exactly one argument"); - } - - attr = mop_fetch_attr(aTHX_ ST(0), key, FALSE, cv); - ST(0) = attr ? attr : &PL_sv_undef; - XSRETURN(1); -} - -XS(mop_xs_simple_writer) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - - if (items != 2) { - croak("expected exactly two argument"); - } - - attr = mop_fetch_attr(aTHX_ ST(0), key, TRUE, cv); - sv_setsv(attr, ST(1)); - ST(0) = attr; - XSRETURN(1); -} - -XS(mop_xs_simple_clearer) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - - if (items != 1) { - croak("expected exactly one argument"); - } - - attr = mop_delete_attr(aTHX_ ST(0), key, cv); - ST(0) = attr ? attr : &PL_sv_undef; - XSRETURN(1); -} - - -XS(mop_xs_simple_predicate) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - - if (items != 1) { - croak("expected exactly one argument"); - } - - attr = mop_fetch_attr(aTHX_ ST(0), key, FALSE, cv); - ST(0) = boolSV(attr); /* exists */ - XSRETURN(1); -} - - -XS(mop_xs_simple_predicate_for_metaclass) -{ - dVAR; dXSARGS; - MAGIC* const mg = mop_mg_find_by_vtbl(aTHX_ (SV*)cv, &mop_accessor_vtbl); - SV* const key = mg->mg_obj; - SV* attr; - - if (items != 1) { - croak("expected exactly one argument"); - } - - attr = mop_fetch_attr(aTHX_ ST(0), key, FALSE, cv); - ST(0) = boolSV(attr && SvOK(attr)); /* defined */ - XSRETURN(1); -} diff --git a/mop.h b/mop.h index 08b448e..594b4fe 100644 --- a/mop.h +++ b/mop.h @@ -1,6 +1,7 @@ #ifndef __MOP_H__ #define __MOP_H__ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -21,18 +22,6 @@ void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark); #define MAKE_KEYSV(name) newSVpvn_share(#name, sizeof(#name)-1, 0U) -CV* mop_install_simple_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(accessor_impl)); - -#define INSTALL_SIMPLE_READER(klass, name) INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name) -#define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) (void)mop_install_simple_accessor(aTHX_ "Class::MOP::" #klass "::" #name, #key, sizeof(#key)-1, mop_xs_simple_reader) - -#define INSTALL_SIMPLE_WRITER(klass, name) INSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, name) -#define INSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, key) (void)mop_install_simple_accessor(aTHX_ "Class::MOP::" #klass "::" #name, #key, sizeof(#key)-1, mop_xs_simple_writer) - -#define INSTALL_SIMPLE_PREDICATE(klass, name) INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, name) -#define INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, key) (void)mop_install_simple_accessor(aTHX_ "Class::MOP::" #klass "::has_" #name, #key, sizeof(#key)-1, mop_xs_simple_predicate_for_metaclass) - - XS(mop_xs_simple_accessor); XS(mop_xs_simple_reader); XS(mop_xs_simple_writer); @@ -55,6 +44,11 @@ extern SV *mop_ISA; UV mop_check_package_cache_flag(pTHX_ HV *stash); int mop_get_code_info (SV *coderef, char **pkg, char **name); SV *mop_call0(pTHX_ SV *const self, SV *const method); +SV *mop_call1(pTHX_ SV *const self, SV *const method, SV *const arg1); + +#define mop_call0_pvs(o, m) mop_call0(aTHX_ o, newSVpvs_flags(m, SVs_TEMP)) +#define mop_call1_pvs(o, m, a) mop_call1(aTHX_ o, newSVpvs_flags(m, SVs_TEMP), a) + typedef enum { TYPE_FILTER_NONE, @@ -68,6 +62,52 @@ typedef enum { typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *); void mop_get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud); -HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter); +HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter); + + +/* Class::MOP::Instance stuff */ + +typedef struct { + SV* (*create_instance)(pTHX); + bool (*has_slot) (pTHX_ SV* const instance, SV* const slot_name); + SV* (*get_slot) (pTHX_ SV* const instance, SV* const slot_name); + SV* (*set_slot) (pTHX_ SV* const instance, SV* const slot_name, SV* const value); + SV* (*delete_slot) (pTHX_ SV* const instance, SV* const slot_name); + void (*weaken_slot) (pTHX_ SV* const instance, SV* const slot_name); +} mop_instance_vtbl; + +const mop_instance_vtbl* mop_get_default_instance_vtbl(pTHX); + +#define MOP_mg_meta(mg) ((AV*)(mg)->mg_obj) +#ifdef DEBUGGING +#define MOP_mg_key(mg) (*av_fetch( MOP_mg_meta(mg) , 0, TRUE)) +#else +#define MOP_mg_key(mg) (AvARRAY( MOP_mg_meta(mg))[0]) +#endif +#define MOP_mg_vtbl(mg) ((const mop_instance_vtbl*)(mg)->mg_ptr) + +/* Class::MOP::Method::Accessor stuff */ + +#define dMOP_METHOD_COMMON \ + SV* const self = mop_accessor_get_self(aTHX_ ax, items, cv); \ + MAGIC* const mg = mop_accessor_get_mg(aTHX_ cv) \ + + +SV* mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv); +MAGIC* mop_accessor_get_mg(pTHX_ CV* const cv); + +CV* mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(accessor_impl), const mop_instance_vtbl* vtbl); + +#define INSTALL_SIMPLE_READER(klass, name) INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name) +#define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) (void)mop_install_accessor(aTHX_ "Class::MOP::" #klass "::" #name, #key, sizeof(#key)-1, mop_xs_simple_reader, NULL) + +#define INSTALL_SIMPLE_WRITER(klass, name) INSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, name) +#define INSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, key) (void)mop_install_accessor(aTHX_ "Class::MOP::" #klass "::" #name, #key, sizeof(#key)-1, mop_xs_simple_writer, NULL) + +#define INSTALL_SIMPLE_PREDICATE(klass, name) INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, name) +#define INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, key) (void)mop_install_accessor(aTHX_ "Class::MOP::" #klass "::has_" #name, #key, sizeof(#key)-1, mop_xs_simple_predicate_for_metaclass, NULL) + +#define MOPf_DIE_ON_FAIL 0x01 +MAGIC* mop_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags); #endif diff --git a/xs/Instance.xs b/xs/Instance.xs old mode 100755 new mode 100644 index ecef003..46aecd1 --- a/xs/Instance.xs +++ b/xs/Instance.xs @@ -1,8 +1,99 @@ #include "mop.h" +#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"); \ + } \ + } STMT_END + +static SV* +mop_instance_create_instance(pTHX) { + return newRV_noinc((SV*)newHV()); +} + +static bool +mop_instance_has_slot(pTHX_ SV* const instance, SV* const slot_name) { + CHECK_INSTANCE(instance); + return hv_exists_ent((HV*)SvRV(instance), slot_name, 0U); +} + +static SV* +mop_instance_get_slot(pTHX_ SV* const instance, SV* const slot_name) { + HE* he; + CHECK_INSTANCE(instance); + he = hv_fetch_ent((HV*)SvRV(instance), slot_name, FALSE, 0U); + return he ? HeVAL(he) : NULL; +} + +static SV* +mop_instance_set_slot(pTHX_ SV* const instance, SV* const slot_name, SV* const value) { + HE* he; + SV* sv; + CHECK_INSTANCE(instance); + he = hv_fetch_ent((HV*)SvRV(instance), slot_name, TRUE, 0U); + sv = HeVAL(he); + sv_setsv_mg(sv, value); + return sv; +} + +static SV* +mop_instance_delete_slot(pTHX_ SV* const instance, SV* const slot_name) { + CHECK_INSTANCE(instance); + return hv_delete_ent((HV*)SvRV(instance), slot_name, 0, 0U); +} + +static void +mop_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot_name) { + HE* he; + CHECK_INSTANCE(instance); + he = hv_fetch_ent((HV*)SvRV(instance), slot_name, FALSE, 0U); + sv_rvweaken(HeVAL(he)); +} + +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, +}; + + +const mop_instance_vtbl* +mop_get_default_instance_vtbl(pTHX){ + return &mop_default_instance; +} + + MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Instance, associated_metaclass); + +void* +can_xs(SV* self) +PREINIT: + SV* const can = newSVpvs_flags("can", SVs_TEMP); + SV* const default_class = newSVpvs_flags("Class::MOP::Instance", SVs_TEMP); + SV* const create_instance = newSVpvs_flags("create_instance", SVs_TEMP); + SV* m1; + SV* m2; +CODE: + /* $self->can("create_instance") == Class::MOP::Instance->can("create_instance") */ + m1 = mop_call1(aTHX_ self, can, create_instance); + m2 = mop_call1(aTHX_ default_class, can, create_instance); + if(SvROK(m1) && SvROK(m2) && SvRV(m1) == SvRV(m2)){ + RETVAL = (void*)&mop_default_instance; + } + else{ + RETVAL = NULL; + } +OUTPUT: + RETVAL + diff --git a/xs/MethodAccessor.xs b/xs/MethodAccessor.xs old mode 100755 new mode 100644 index 86dad34..0dfe4f3 --- a/xs/MethodAccessor.xs +++ b/xs/MethodAccessor.xs @@ -1,11 +1,149 @@ #include "mop.h" + +static MGVTBL mop_accessor_vtbl; /* the MAGIC identity */ + +MAGIC* +mop_accessor_get_mg(pTHX_ CV* const xsub){ + return mop_mg_find(aTHX_ (SV*)xsub, &mop_accessor_vtbl, MOPf_DIE_ON_FAIL); +} + +CV* +mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(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); + AV* const meta = newAV(); + + if(!vtbl){ + vtbl = mop_get_default_instance_vtbl(aTHX); + } + + sv_magicext((SV*)xsub, (SV*)meta, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0); + SvREFCNT_dec(meta); /* sv_magicext() increases refcnt in mg_obj */ + + av_store(meta, 0, keysv); + + return xsub; +} + + static CV* -mop_instantiate_xs_accessor(pTHX_ SV* const meta_attr, XSPROTO(accessor_impl)){ - SV* const key = mop_call0(aTHX_ meta_attr, sv_2mortal(newSVpvs("attribute_name"))); - STRLEN len; - const char* const pv = SvPV_const(key, len); - return mop_install_simple_accessor(aTHX_ NULL /* anonymous */, pv, len, accessor_impl); +mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl), mop_instance_vtbl* const vtbl){ + /* $key = $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); + + return mop_install_accessor(aTHX_ NULL /* anonymous */, kpv, klen, accessor_impl, vtbl); +} + +SV* +mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv) { + SV* self; + + if(items < 1){ + croak("too few arguments for %s", GvNAME(CvGV(cv))); + } + + self = ST(0); + if(!(SvROK(self) && SvOBJECT(SvRV(self)))){ + croak("cant call %s as a class method", GvNAME(CvGV(cv))); + } + return self; +} + +XS(mop_xs_simple_accessor) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + SV* value; + if(items == 1){ /* reader */ + value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg)); + } + else if (items == 2){ /* writer */ + value = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1)); + } + else{ + croak("expected exactly one or two argument"); + } + + ST(0) = value ? value : &PL_sv_undef; + XSRETURN(1); +} + + +XS(mop_xs_simple_reader) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + SV* value; + + if (items != 1) { + croak("expected exactly one argument"); + } + + value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg)); + ST(0) = value ? value : &PL_sv_undef; + XSRETURN(1); +} + +XS(mop_xs_simple_writer) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + + if (items != 2) { + croak("expected exactly two argument"); + } + + ST(0) = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1)); + XSRETURN(1); +} + +XS(mop_xs_simple_clearer) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + SV* value; + + if (items != 1) { + croak("expected exactly one argument"); + } + + value = MOP_mg_vtbl(mg)->delete_slot(aTHX_ self, MOP_mg_key(mg)); + ST(0) = value ? value : &PL_sv_undef; + XSRETURN(1); +} + + +XS(mop_xs_simple_predicate) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + + if (items != 1) { + croak("expected exactly one argument"); + } + + ST(0) = boolSV( MOP_mg_vtbl(mg)->has_slot(aTHX_ self, MOP_mg_key(mg)) ); + XSRETURN(1); +} + + +XS(mop_xs_simple_predicate_for_metaclass) +{ + dVAR; dXSARGS; + dMOP_METHOD_COMMON; /* self, mg */ + SV* value; + + if (items != 1) { + croak("expected exactly one argument"); + } + + value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg)); + ST(0) = boolSV( value && SvOK(value )); + XSRETURN(1); } MODULE = Class::MOP::Method::Accessor PACKAGE = Class::MOP::Method::Accessor @@ -18,37 +156,37 @@ BOOT: CV* -_generate_accessor_method_xs(SV* self) +_generate_accessor_method_xs(SV* self, void* instance_vtbl) CODE: - RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor); + RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor, instance_vtbl); OUTPUT: RETVAL CV* -_generate_reader_method_xs(SV* self) +_generate_reader_method_xs(SV* self, void* instance_vtbl) CODE: - RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader); + RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader, instance_vtbl); OUTPUT: RETVAL CV* -_generate_writer_method_xs(SV* self) +_generate_writer_method_xs(SV* self, void* instance_vtbl) CODE: - RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer); + RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer, instance_vtbl); OUTPUT: RETVAL CV* -_generate_predicate_method_xs(SV* self) +_generate_predicate_method_xs(SV* self, void* instance_vtbl) CODE: - RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate); + RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate, instance_vtbl); OUTPUT: RETVAL CV* -_generate_clearer_method_xs(SV* self) +_generate_clearer_method_xs(SV* self, void* instance_vtbl) CODE: - RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer); + RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer, instance_vtbl); OUTPUT: RETVAL