test_requires 'Test::More' => '0.88';
test_requires 'Test::Exception' => '0.27';
-extra_tests();
+install_headers('mop.h');
+
+#extra_tests();
makemaker_args( CCFLAGS => $ccflags );
$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.
=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
#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 {
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;
};
}
-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;
};
}
+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])
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)
{
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);
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)) {
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);
-}
#ifndef __MOP_H__
#define __MOP_H__
+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#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);
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,
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
#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
+
#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
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
projects / gitmo/Class-MOP.git / commitdiff