refactor a Class::MOP::Method::Inlined base class

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 087c8cd..6597463 100644 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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