lib/Class/MOP/Object.pm
lib/Class/MOP/Package.pm
lib/metaclass.pm
+MOP.xs
Makefile.PL
MANIFEST
META.yml
--- /dev/null
+
+#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)));
+ }
+
use strict;
use warnings;
-use inc::Module::Install;
+use inc::Module::Install 0.65;
name 'Class-MOP';
all_from 'lib/Class/MOP.pm';
build_requires 'Test::Exception' => '0.21';
build_requires 'File::Spec' => '0';
+auto_provides;
WriteAll();
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
determine as best it can if the C<$class_name> is loaded, it
is probably correct about 99% of the time.
+=item B<check_package_cache_flag>
+
+=item B<get_code_info ($code)>
+
=back
=head2 Metaclass cache functions
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';
'$!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 {
# 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);
$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;
# 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;
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);
}
my $full_method_name = ($self->name . '::' . $method_name);
$self->add_package_symbol("&${method_name}" => subname $full_method_name => $body);
+ $self->reset_package_cache_flag;
}
{
|| confess "Your code block must be a CODE reference";
$self->add_package_symbol("&${method_name}" => $body);
+ $self->reset_package_cache_flag;
}
sub has_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;
}
your ancestors. For more inforamtion about metaclass compatibility
see the C<About Metaclass compatibility> section in L<Class::MOP>.
+=item B<reset_package_cache_flag>
+
+This will reset the package cache flag for this particular metaclass
+it is basically the value of the C<Class::MOP::get_package_cache_flag>
+function. This is very rarely needed from outside of C<Class::MOP::Class>
+but in some cases you might want to use it, so it is here.
+
=back
=head2 Object instance construction and cloning
use Carp 'confess';
use Scalar::Util 'reftype', 'blessed';
-use B 'svref_2object';
+#use B 'svref_2object';
our $VERSION = '0.05';
our $AUTHORITY = 'cpan:STEVAN';
# 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:
# 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 {
use strict;
use warnings;
-use Test::More tests => 199;
+use Test::More tests => 201;
use Test::Exception;
BEGIN {
meta
initialize reinitialize create
+
+ reset_package_cache_flag
create_anon_class is_anon_class
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');
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');
projects / gitmo/Class-MOP.git / commitdiff