From: Yuval Kogman Date: Sun, 19 Apr 2009 11:50:11 +0000 (+0200) Subject: refactor a Class::MOP::Method::Inlined base class X-Git-Tag: 0.82_01~11^2~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=29d4e92ae9c54d6a4a9b949a10e22d2163653470;p=gitmo%2FClass-MOP.git refactor a Class::MOP::Method::Inlined base class --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 087c8cd..6597463 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -570,6 +570,16 @@ Class::MOP::Method::Generated->meta->add_attribute( )) ); + +## -------------------------------------------------------- +## Class::MOP::Method::Inlined + +Class::MOP::Method::Inlined->meta->add_attribute( + Class::MOP::Attribute->new('_expected_method_class' => ( + reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class }, + )) +); + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -680,6 +690,7 @@ $_->meta->make_immutable( Class::MOP::Object Class::MOP::Method::Generated + Class::MOP::Method::Inlined Class::MOP::Method::Accessor Class::MOP::Method::Constructor diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 079da6c..39458e9 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -11,7 +11,7 @@ our $VERSION = '0.81'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Class::MOP::Method::Generated'; +use base 'Class::MOP::Method::Inlined'; sub new { my $class = shift; @@ -52,8 +52,6 @@ sub _new { }, $class; } -sub can_be_inlined { 1 } - ## accessors sub options { (shift)->{'options'} } diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm new file mode 100644 index 0000000..3a4fd51 --- /dev/null +++ b/lib/Class/MOP/Method/Inlined.pm @@ -0,0 +1,90 @@ +package Class::MOP::Method::Inlined; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; + +our $VERSION = '0.81'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method::Generated'; + +sub _expected_method_class { $_[0]{_expected_method_class} } + +sub _uninlined_body { + my $self = shift; + + if ( my $super_method = $self->associated_metaclass->find_next_method_by_name( $self->name ) ) { + if ( $super_method->isa(__PACKAGE__) ) { + return $super_method->_uninlined_body; + } else { + return $super_method->body; + } + } else { + return; + } +} + +sub can_be_inlined { + my $self = shift; + my $metaclass = $self->associated_metaclass; + my $class = $metaclass->name; + + if ( my $expected_class = $self->_expected_method_class ) { + + # if we are shadowing a method we first verify that it is + # compatible with the definition we are replacing it with + my $expected_method = $expected_class->can($self->name); + + my $warning + = "Not inlining '" . $self->name . "' for $class since it is not" + . " inheriting the default ${expected_class}::" . $self->name . "\n" + . "If you are certain you don't need to inline your"; + + if ( $self->isa("Class::MOP::Method::Constructor") ) { + # FIXME kludge, refactor warning generation to a method + $warning .= " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + } + + if ( my $actual_method = $class->can($self->name) ) { + if ( refaddr($expected_method) == refaddr($actual_method) ) { + # the method is what we wanted (probably Moose::Object::new) + return 1; + } elsif ( my $inherited_method = $metaclass->find_next_method_by_name( $self->name ) ) { + # otherwise we have to check that the actual method is an + # inlined version of what we're expecting + if ( $inherited_method->isa(__PACKAGE__) ) { + if ( refaddr($inherited_method->_uninlined_body) == refaddr($expected_method) ) { + return 1; + } + } elsif ( refaddr($inherited_method->body) == refaddr($expected_method) ) { + return 1; + } + + # FIXME we can just rewrap them =P + $warning .= " ('" . $self->name . "' has method modifiers which would be lost if it were inlined)\n" + if $inherited_method->isa('Class::MOP::Method::Wrapped'); + } + } else { + # This would be a rather weird case where we have no method + # in the inheritance chain even though we're expecting one to be + # there + + # this returns 1 for backwards compatibility for now + return 1; + } + + warn $warning; + + return 0; + } else { + # there is no expected class so we just install the constructor as a + # new method + return 1; + } +} + diff --git a/t/000_load.t b/t/000_load.t index 7be801d..6e82101 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -1,17 +1,19 @@ use strict; use warnings; -use Test::More tests => 45; +use Test::More tests => 49; BEGIN { use_ok('Class::MOP'); use_ok('Class::MOP::Package'); use_ok('Class::MOP::Module'); use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Class::Immutable::Trait'); use_ok('Class::MOP::Immutable'); use_ok('Class::MOP::Attribute'); use_ok('Class::MOP::Method'); use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Inlined'); use_ok('Class::MOP::Method::Generated'); use_ok('Class::MOP::Method::Accessor'); use_ok('Class::MOP::Method::Constructor'); @@ -23,6 +25,7 @@ BEGIN { my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, + 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, 'Class::MOP::Method::Constructor' => @@ -64,6 +67,7 @@ is_deeply( Class::MOP::Method::Accessor->meta, Class::MOP::Method::Constructor->meta, Class::MOP::Method::Generated->meta, + Class::MOP::Method::Inlined->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, @@ -85,6 +89,7 @@ is_deeply( Class::MOP::Method::Accessor Class::MOP::Method::Constructor Class::MOP::Method::Generated + Class::MOP::Method::Inlined Class::MOP::Method::Wrapped Class::MOP::Module Class::MOP::Object