From: gfx <gfuji@cpan.org>
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=353c61527f40579045dde49a8671eddb38f08c4b;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 8f2f6ac..14bce9a 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -34,9 +34,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 bcd6576..8023e93 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -402,6 +402,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 c6c4284..76bfe5e 100644
--- a/lib/Class/MOP/Method/Accessor.pm
+++ b/lib/Class/MOP/Method/Accessor.pm
@@ -74,15 +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_metaclass->instance_metaclass eq 'Class::MOP::Instance';
-}
-
 ## factory
 
 sub initialize_body {
@@ -97,25 +88,95 @@ sub _initialize_body {
     my $method_name = join "_" => (
         '_generate',
         $self->accessor_type,
-        'method'
+        'method',
     );
 
+    $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){
-        $method_name .= $self->_can_xs($method_name) ? '_xs' : '_inline';
+        return $self->_generate_accessor_method_inline();
     }
 
-    $self->{'body'} = $self->$method_name();
+    return $self->_generate_accessor_method_basic();
 }
 
-## generators
+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;
+    shift->_generate_accessor_method_basic;
 }
 
-sub _generate_accessor_method {
+sub _generate_accessor_method_basic {
     my $attr = (shift)->associated_attribute;
     return sub {
         $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
@@ -126,10 +187,10 @@ sub _generate_accessor_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;
+    shift->_generate_reader_method_basic;
 }
 
-sub _generate_reader_method {
+sub _generate_reader_method_basic {
     my $attr = (shift)->associated_attribute;
     return sub {
         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
@@ -140,10 +201,10 @@ 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;
+    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]);
@@ -153,10 +214,10 @@ sub _generate_writer_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;
+    shift->_generate_predicate_method_basic;
 }
 
-sub _generate_predicate_method {
+sub _generate_predicate_method_basic {
     my $attr = (shift)->associated_attribute;
     return sub {
         $attr->has_value($_[0])
@@ -166,10 +227,10 @@ sub _generate_predicate_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;
+    shift->_generate_clearer_method_basic;
 }
 
-sub _generate_clearer_method {
+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 062b59f..4299335 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);
@@ -183,6 +206,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)) {
@@ -195,165 +219,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 3f9134a..cbab146 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);
@@ -56,6 +45,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,
@@ -69,6 +63,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 037ed41..0dfe4f3
--- a/xs/MethodAccessor.xs
+++ b/xs/MethodAccessor.xs
@@ -1,13 +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 accessor, XSPROTO(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 len;
-    const char* const pv = SvPV_const(key, len);
-    return mop_install_simple_accessor(aTHX_ NULL /* anonymous */, pv, len, accessor_impl);
+    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
@@ -20,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