From: Stevan Little Date: Wed, 12 Dec 2007 21:14:20 +0000 (+0000) Subject: Class::MOP with XS X-Git-Tag: 0_49~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e0e4674a7071c8b072752ac5d4e450f778cb8766;hp=6c9f390e94daff3a3c7e21914c12f5c4288ef0dc;p=gitmo%2FClass-MOP.git Class::MOP with XS --- diff --git a/MANIFEST b/MANIFEST index 5f2b5b4..29cbddf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -30,6 +30,7 @@ lib/Class/MOP/Module.pm lib/Class/MOP/Object.pm lib/Class/MOP/Package.pm lib/metaclass.pm +MOP.xs Makefile.PL MANIFEST META.yml diff --git a/MOP.xs b/MOP.xs new file mode 100644 index 0000000..ce2e865 --- /dev/null +++ b/MOP.xs @@ -0,0 +1,43 @@ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* +check_method_cache_flag: + check the PL_sub_generation + ISA/method cache thing + +get_code_info: + Pass in a coderef, returns: + [ $pkg_name, $coderef_name ] ie: + [ 'Foo::Bar', 'new' ] +*/ + +MODULE = Class::MOP PACKAGE = Class::MOP + +SV* +check_package_cache_flag() + CODE: + RETVAL = newSViv(PL_sub_generation); + OUTPUT: + RETVAL + +void +get_code_info(coderef) + SV* coderef + PREINIT: + char* name; + char* pkg; + PPCODE: + + if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){ + coderef = SvRV(coderef); + name = GvNAME( CvGV(coderef) ); + pkg = HvNAME( GvSTASH(CvGV(coderef)) ); + + EXTEND(SP, 2); + PUSHs(newSVpvn(pkg, strlen(pkg))); + PUSHs(newSVpvn(name, strlen(name))); + } + diff --git a/Makefile.PL b/Makefile.PL index b313ce8..e03177e 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,6 +1,6 @@ use strict; use warnings; -use inc::Module::Install; +use inc::Module::Install 0.65; name 'Class-MOP'; all_from 'lib/Class/MOP.pm'; @@ -15,4 +15,5 @@ build_requires 'Test::More' => '0.62'; build_requires 'Test::Exception' => '0.21'; build_requires 'File::Spec' => '0'; +auto_provides; WriteAll(); diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 56f55fe..4c18e4c 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -16,6 +16,9 @@ use Class::MOP::Immutable; our $VERSION = '0.49'; our $AUTHORITY = 'cpan:STEVAN'; +use XSLoader; +XSLoader::load( 'Class::MOP', $VERSION ); + { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though @@ -732,6 +735,10 @@ NOTE: This does a basic check of the symbol table to try and determine as best it can if the C<$class_name> is loaded, it is probably correct about 99% of the time. +=item B + +=item B + =back =head2 Metaclass cache functions diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 28bd7c3..789ebe4 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,7 +11,6 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; -use B 'svref_2object'; our $VERSION = '0.25'; our $AUTHORITY = 'cpan:STEVAN'; @@ -104,6 +103,14 @@ sub construct_class_instance { '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', + + ## uber-private variables + # NOTE: + # this starts out as undef so that + # we can tell the first time the + # methods are fetched + # - SL + '$!_package_cache_flag' => undef, } => $class; } else { @@ -116,6 +123,10 @@ sub construct_class_instance { # and check the metaclass compatibility $meta->check_metaclass_compatability(); + + # initialize some stuff + $meta->get_method_map; + $meta->reset_package_cache_flag; Class::MOP::store_metaclass_by_name($package_name, $meta); @@ -127,6 +138,16 @@ sub construct_class_instance { $meta; } +sub reset_package_cache_flag { + # NOTE: + # we can manually update the cache number + # since we are actually adding the method + # to our cache as well. This avoids us + # having to regenerate the method_map. + # - SL + (shift)->{'$!_package_cache_flag'} = Class::MOP::check_package_cache_flag(); +} + sub check_metaclass_compatability { my $self = shift; @@ -275,6 +296,12 @@ sub instance_metaclass { $_[0]->{'$!instance_metaclass'} } # this is a prime canidate for conversion to XS sub get_method_map { my $self = shift; + + if (defined $self->{'$!_package_cache_flag'} && + $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag()) { + return $self->{'%!methods'}; + } + my $map = $self->{'%!methods'}; my $class_name = $self->name; @@ -287,9 +314,9 @@ sub get_method_map { defined $map->{$symbol} && $map->{$symbol}->body == $code; - my $gv = svref_2object($code)->GV; - next if ($gv->STASH->NAME || '') ne $class_name && - ($gv->NAME || '') ne '__ANON__'; + my ($pkg, $name) = Class::MOP::get_code_info($code); + next if ($pkg || '') ne $class_name && + ($name || '') ne '__ANON__'; $map->{$symbol} = $method_metaclass->wrap($code); } @@ -474,6 +501,7 @@ sub add_method { my $full_method_name = ($self->name . '::' . $method_name); $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body); + $self->reset_package_cache_flag; } { @@ -550,6 +578,7 @@ sub alias_method { || confess "Your code block must be a CODE reference"; $self->add_package_symbol("&${method_name}" => $body); + $self->reset_package_cache_flag; } sub has_method { @@ -580,12 +609,11 @@ sub remove_method { (defined $method_name && $method_name) || confess "You must define a method name"; - my $removed_method = $self->get_method($method_name); - - do { - $self->remove_package_symbol("&${method_name}"); - delete $self->get_method_map->{$method_name}; - } if defined $removed_method; + my $removed_method = delete $self->get_method_map->{$method_name}; + + $self->remove_package_symbol("&${method_name}"); + + $self->reset_package_cache_flag; return $removed_method; } @@ -964,6 +992,13 @@ metaclass you are creating is compatible with the metaclasses of all your ancestors. For more inforamtion about metaclass compatibility see the C section in L. +=item B + +This will reset the package cache flag for this particular metaclass +it is basically the value of the C +function. This is very rarely needed from outside of C +but in some cases you might want to use it, so it is here. + =back =head2 Object instance construction and cloning diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index ba0218c..4c0a083 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -6,7 +6,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; -use B 'svref_2object'; +#use B 'svref_2object'; our $VERSION = '0.05'; our $AUTHORITY = 'cpan:STEVAN'; @@ -52,7 +52,7 @@ sub body { (shift)->{'&!body'} } # associated with the actual CODE-ref sub package_name { my $code = (shift)->body; - svref_2object($code)->GV->STASH->NAME; + (Class::MOP::get_code_info($code))[0]; } # NOTE: @@ -62,7 +62,7 @@ sub package_name { # with the actual CODE-ref sub name { my $code = (shift)->body; - svref_2object($code)->GV->NAME; + (Class::MOP::get_code_info($code))[1]; } sub fully_qualified_name { diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 69f3c48..14cd9ca 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 199; +use Test::More tests => 201; use Test::Exception; BEGIN { @@ -51,6 +51,8 @@ my @class_mop_class_methods = qw( meta initialize reinitialize create + + reset_package_cache_flag create_anon_class is_anon_class diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t index bc83ae6..e753208 100644 --- a/t/073_make_mutable.t +++ b/t/073_make_mutable.t @@ -67,7 +67,7 @@ BEGIN { ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method'); is( Baz->zxy, 'xxx', '... method zxy works'); ok( $meta->remove_method('xyz'), '... removed method'); - ok( $meta->remove_method('zxy'), '... removed aliased method'); + ok(! $meta->remove_method('zxy'), '... removed aliased method'); ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); ok(Baz->can('fickle'), '... Baz can fickle'); @@ -159,7 +159,7 @@ BEGIN { ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method'); is( $instance->zxy, 'xxx', '... method zxy works'); ok( $meta->remove_method('xyz'), '... removed method'); - ok( $meta->remove_method('zxy'), '... removed aliased method'); + ok( !$meta->remove_method('zxy'), '... removed aliased method'); ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); ok($instance->can('fickle'), '... instance can fickle');