From: Dave Rolsky <autarch@urth.org>
Date: Fri, 2 Sep 2011 01:37:36 +0000 (-0500)
Subject: work in progress on moving all method bits up to CMOP
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b0f4faf6f44c1aeb31569b79c625fb79060a80d;p=gitmo%2FMoose.git

work in progress on moving all method bits up to CMOP
---

diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index 13b0741..935d19d 100644
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -133,6 +133,48 @@ sub clone {
     return $clone;
 }
 
+sub _error_thrower {
+    my $self = shift;
+    require Moose::Meta::Class;
+
+    return $self->associated_metaclass
+        if ref $self
+            && $self->associated_metaclass
+            && $self->associated_metaclass->can('throw_error');
+
+    return 'Moose::Meta::Class';
+}
+
+sub throw_error {
+    my $self = shift;
+    my $inv = $self->_error_thrower;
+    unshift @_, "message" if @_ % 2 == 1;
+    unshift @_, method => $self if ref $self;
+    unshift @_, $inv;
+    my $handler = $inv->can("throw_error");
+    goto $handler; # to avoid incrementing depth by 1
+}
+
+sub _inline_throw_error {
+    my ( $self, $msg, $args ) = @_;
+
+    my $inv = $self->_error_thrower;
+    # XXX ugh
+    $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
+
+    # XXX ugh ugh UGH
+    my $class = $self->associated_metaclass;
+    if ($class) {
+        my $class_name = B::perlstring($class->name);
+        my $meth_name = B::perlstring($self->name);
+        $args = 'method => Class::MOP::class_of(' . $class_name . ')'
+              . '->find_method_by_name(' . $meth_name . '), '
+              . (defined $args ? $args : '');
+    }
+
+    return $inv->_inline_throw_error($msg, $args)
+}
+
 1;
 
 # ABSTRACT: Method Meta Object
diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm
index aa7b8b8..7767234 100644
--- a/lib/Class/MOP/Method/Accessor.pm
+++ b/lib/Class/MOP/Method/Accessor.pm
@@ -77,17 +77,82 @@ sub _initialize_body {
     my $method_name = join "_" => (
         '_generate',
         $self->accessor_type,
-        'method',
-        ($self->is_inline ? 'inline' : ())
+        'method'
     );
 
     $self->{'body'} = $self->$method_name();
 }
 
-## generators
+sub _error_thrower {
+    my $self = shift;
+
+    return $self->associated_attribute
+        if ref $self
+            && $self->associated_attribute
+            && $self->associated_attribute->can('throw_error');
+
+    return $self->SUPER::_error_thrower;
+}
+
+sub _compile_code {
+    my $self = shift;
+    my @args = @_;
+    try {
+        $self->SUPER::_compile_code(@args);
+    }
+    catch {
+        $self->throw_error(
+            'Could not create writer for '
+          . "'" . $self->associated_attribute->name . "' "
+          . 'because ' . $_,
+            error => $_,
+        );
+    };
+}
+
+sub _eval_environment {
+    my $self = shift;
+    return $self->associated_attribute->_eval_environment
+        if $self->associated_attribute->can('_eval_environment');
+}
+
+sub _instance_is_inlinable {
+    my $self = shift;
+    return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
+}
+
+sub _generate_reader_method {
+    my $self = shift;
+    $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
+                                  : $self->_generate_reader_method_non_inline(@_);
+}
+
+sub _generate_writer_method {
+    my $self = shift;
+    $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
+                                  : $self->_generate_writer_method_non_inline(@_);
+}
 
 sub _generate_accessor_method {
     my $self = shift;
+    $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
+                                  : $self->_generate_accessor_method_non_inline(@_);
+}
+
+sub _generate_predicate_method {
+    my $self = shift;
+    $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
+                                  : $self->_generate_predicate_method_non_inline(@_);
+}
+
+sub _generate_clearer_method {
+    my $self = shift;
+    $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
+                                  : $self->_generate_clearer_method_non_inline(@_);
+}
+
+sub _generate_accessor_method_non_inline {
+    my $self = shift;
     my $attr = $self->associated_attribute;
 
     return sub {
@@ -117,7 +182,7 @@ sub _generate_accessor_method_inline {
     };
 }
 
-sub _generate_reader_method {
+sub _generate_reader_method_non_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
@@ -156,7 +221,7 @@ sub _inline_throw_error {
     return 'Carp::confess ' . $_[0];
 }
 
-sub _generate_writer_method {
+sub _generate_writer_method_non_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
@@ -181,7 +246,7 @@ sub _generate_writer_method_inline {
     };
 }
 
-sub _generate_predicate_method {
+sub _generate_predicate_method_non_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
@@ -206,7 +271,7 @@ sub _generate_predicate_method_inline {
     };
 }
 
-sub _generate_clearer_method {
+sub _generate_clearer_method_non_inline {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
@@ -231,6 +296,46 @@ sub _generate_clearer_method_inline {
     };
 }
 
+sub _writer_value_needs_copy {
+    shift->associated_attribute->_writer_value_needs_copy(@_);
+}
+
+sub _inline_tc_code {
+    shift->associated_attribute->_inline_tc_code(@_);
+}
+
+sub _inline_check_coercion {
+    shift->associated_attribute->_inline_check_coercion(@_);
+}
+
+sub _inline_check_constraint {
+    shift->associated_attribute->_inline_check_constraint(@_);
+}
+
+sub _inline_check_lazy {
+    shift->associated_attribute->_inline_check_lazy(@_);
+}
+
+sub _inline_store_value {
+    shift->associated_attribute->_inline_instance_set(@_) . ';';
+}
+
+sub _inline_get_old_value_for_trigger {
+    shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
+}
+
+sub _inline_trigger {
+    shift->associated_attribute->_inline_trigger(@_);
+}
+
+sub _get_value {
+    shift->associated_attribute->_inline_instance_get(@_);
+}
+
+sub _has_value {
+    shift->associated_attribute->_inline_instance_has(@_);
+}
+
 1;
 
 # ABSTRACT: Method Meta Object for accessors
diff --git a/lib/Moose/Meta/Method.pm b/lib/Moose/Meta/Method.pm
index c6d14fc..5670ff0 100644
--- a/lib/Moose/Meta/Method.pm
+++ b/lib/Moose/Meta/Method.pm
@@ -5,42 +5,6 @@ use warnings;
 
 use base 'Class::MOP::Method';
 
-sub _error_thrower {
-    my $self = shift;
-    require Moose::Meta::Class;
-    ( ref $self && $self->associated_metaclass ) || "Moose::Meta::Class";
-}
-
-sub throw_error {
-    my $self = shift;
-    my $inv = $self->_error_thrower;
-    unshift @_, "message" if @_ % 2 == 1;
-    unshift @_, method => $self if ref $self;
-    unshift @_, $inv;
-    my $handler = $inv->can("throw_error");
-    goto $handler; # to avoid incrementing depth by 1
-}
-
-sub _inline_throw_error {
-    my ( $self, $msg, $args ) = @_;
-
-    my $inv = $self->_error_thrower;
-    # XXX ugh
-    $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
-
-    # XXX ugh ugh UGH
-    my $class = $self->associated_metaclass;
-    if ($class) {
-        my $class_name = B::perlstring($class->name);
-        my $meth_name = B::perlstring($self->name);
-        $args = 'method => Class::MOP::class_of(' . $class_name . ')'
-              . '->find_method_by_name(' . $meth_name . '), '
-              . (defined $args ? $args : '');
-    }
-
-    return $inv->_inline_throw_error($msg, $args)
-}
-
 1;
 
 # ABSTRACT: A Moose Method metaclass
diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index f6ec575..2e69cd6 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -4,122 +4,7 @@ package Moose::Meta::Method::Accessor;
 use strict;
 use warnings;
 
-use Try::Tiny;
-
-use base 'Moose::Meta::Method',
-         'Class::MOP::Method::Accessor';
-
-# multiple inheritance is terrible
-sub new {
-    goto &Class::MOP::Method::Accessor::new;
-}
-
-sub _new {
-    goto &Class::MOP::Method::Accessor::_new;
-}
-
-sub _error_thrower {
-    my $self = shift;
-    return $self->associated_attribute
-        if ref($self) && defined($self->associated_attribute);
-    return $self->SUPER::_error_thrower;
-}
-
-sub _compile_code {
-    my $self = shift;
-    my @args = @_;
-    try {
-        $self->SUPER::_compile_code(@args);
-    }
-    catch {
-        $self->throw_error(
-            'Could not create writer for '
-          . "'" . $self->associated_attribute->name . "' "
-          . 'because ' . $_,
-            error => $_,
-        );
-    };
-}
-
-sub _eval_environment {
-    my $self = shift;
-    return $self->associated_attribute->_eval_environment;
-}
-
-sub _instance_is_inlinable {
-    my $self = shift;
-    return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
-}
-
-sub _generate_reader_method {
-    my $self = shift;
-    $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
-                                  : $self->SUPER::_generate_reader_method(@_);
-}
-
-sub _generate_writer_method {
-    my $self = shift;
-    $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
-                                  : $self->SUPER::_generate_writer_method(@_);
-}
-
-sub _generate_accessor_method {
-    my $self = shift;
-    $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
-                                  : $self->SUPER::_generate_accessor_method(@_);
-}
-
-sub _generate_predicate_method {
-    my $self = shift;
-    $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
-                                  : $self->SUPER::_generate_predicate_method(@_);
-}
-
-sub _generate_clearer_method {
-    my $self = shift;
-    $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
-                                  : $self->SUPER::_generate_clearer_method(@_);
-}
-
-sub _writer_value_needs_copy {
-    shift->associated_attribute->_writer_value_needs_copy(@_);
-}
-
-sub _inline_tc_code {
-    shift->associated_attribute->_inline_tc_code(@_);
-}
-
-sub _inline_check_coercion {
-    shift->associated_attribute->_inline_check_coercion(@_);
-}
-
-sub _inline_check_constraint {
-    shift->associated_attribute->_inline_check_constraint(@_);
-}
-
-sub _inline_check_lazy {
-    shift->associated_attribute->_inline_check_lazy(@_);
-}
-
-sub _inline_store_value {
-    shift->associated_attribute->_inline_instance_set(@_) . ';';
-}
-
-sub _inline_get_old_value_for_trigger {
-    shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
-}
-
-sub _inline_trigger {
-    shift->associated_attribute->_inline_trigger(@_);
-}
-
-sub _get_value {
-    shift->associated_attribute->_inline_instance_get(@_);
-}
-
-sub _has_value {
-    shift->associated_attribute->_inline_instance_has(@_);
-}
+use base 'Class::MOP::Method::Accessor';
 
 1;