From: Dave Rolsky <autarch@urth.org>
Date: Sat, 18 Sep 2010 16:40:21 +0000 (-0500)
Subject: Lots of refactoring to move native trait reader/writer code into base classes shareab... 
X-Git-Tag: 1.15~135
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5df5498008faffca14682ca93face59a9a23a5a6;p=gitmo%2FMoose.git

Lots of refactoring to move native trait reader/writer code into base classes shareable by all native types
---

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm
index 88c4a4f..d76c246 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm
@@ -9,7 +9,7 @@ our $VERSION = '1.13';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
-use base 'Moose::Meta::Method::Accessor::Native';
+# This package is really more of a role, so it doesn't inherit from anything.
 
 sub _inline_check_var_is_valid_index {
     my ( $self, $var ) = @_;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
index d46bea6..7928eac 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Reader.pm
@@ -7,36 +7,9 @@ our $VERSION = '1.13';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
-use base 'Moose::Meta::Method::Accessor::Native::Array';
-
-sub _generate_method {
-    my $self = shift;
-
-    my $inv = '$self';
-
-    my $code = 'sub {';
-    $code .= "\n" . $self->_inline_pre_body(@_);
-
-    $code .= "\n" . 'my $self = shift;';
-    $code .= "\n" . $self->_inline_curried_arguments;
-    $code .= "\n" . $self->_inline_check_argument_count;
-    $code .= "\n" . $self->_inline_check_arguments;
-
-    $code .= "\n" . $self->_inline_check_lazy($inv);
-    $code .= "\n" . $self->_inline_post_body(@_);
-
-    my $slot_access = $self->_inline_get($inv);
-
-    $code .= "\n" . $self->_inline_return_value($slot_access);
-    $code .= "\n}";
-
-    return $code;
-}
-
-sub _inline_return_value {
-    my ( $self, $slot_access ) = @_;
-
-    'return ' . $self->_return_value($slot_access) . ';';
-}
+use base qw(
+    Moose::Meta::Method::Accessor::Native::Array
+    Moose::Meta::Method::Accessor::Native::Reader
+);
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
index 29518ed..1119a4d 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
@@ -7,71 +7,29 @@ our $VERSION = '1.13';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
-use base 'Moose::Meta::Method::Accessor::Native::Array';
+use base qw(
+    Moose::Meta::Method::Accessor::Native::Array
+    Moose::Meta::Method::Accessor::Native::Writer
+);
 
-sub _generate_method {
-    my $self = shift;
-
-    my $inv = '$self';
-
-    my $slot_access = $self->_inline_get($inv);
-
-    my $code = 'sub {';
-    $code .= "\n" . $self->_inline_pre_body(@_);
-
-    $code .= "\n" . 'my $self = shift;';
-
-    $code .= "\n" . $self->_inline_check_lazy($inv);
-
-    $code .= "\n" . $self->_inline_curried_arguments;
-
-    $code .= "\n" . $self->_inline_check_argument_count;
-
-    $code .= "\n" . $self->_inline_process_arguments;
-
-    $code .= "\n" . $self->_inline_check_arguments;
-
-    my $new_values      = $self->_new_values($slot_access);
-    my $potential_value = $self->_potential_value($slot_access);
-
-    if ( $self->_value_needs_copy ) {
-        $code .= "\n" . "my \@potential = $potential_value;";
-        $potential_value = '@potential';
-    }
+sub _inline_process_arguments {q{}}
 
-    $code .= "\n"
-        . $self->_inline_tc_code(
-        $new_values,
-        $potential_value
-        );
+sub _inline_check_arguments {q{}}
 
-    $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
-    $code .= "\n" . $self->_capture_old_value($slot_access);
+sub _new_value {'@_'}
 
-    $code .= "\n"
-        . $self->_inline_store(
-        $inv,
-        $self->_value_needs_copy
-        ? '\\' . $potential_value
-        : '[' . $potential_value . ']'
-        );
+sub _inline_copy_value {
+    my ( $self, $potential_ref ) = @_;
 
-    $code .= "\n" . $self->_inline_post_body(@_);
-    $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
+    return q{} unless $self->_value_needs_copy;
 
-    $code .= "\n" . $self->_return_value( $inv, '@old' );
+    my $code = "my \@potential = ${$potential_ref};";
 
-    $code .= "\n}";
+    ${$potential_ref} = '@potential';
 
     return $code;
 }
 
-sub _inline_process_arguments {q{}}
-
-sub _inline_check_arguments {q{}}
-
-sub _new_values {'@_'}
-
 sub _value_needs_copy {
     my $self = shift;
 
@@ -164,6 +122,16 @@ sub _inline_check_constraint {
 }
 
 sub _capture_old_value { return q{} }
+
+sub _inline_set_new_value {
+    my ( $self, $inv, $new ) = @_;
+
+    return $self->SUPER::_inline_store(
+        $inv,
+        $self->_value_needs_copy ? '\\' . $new : '[' . $new . ']'
+    );
+}
+
 sub _return_value      { return q{} }
 
 sub _eval_environment {
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
new file mode 100644
index 0000000..3304cae
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
@@ -0,0 +1,42 @@
+package Moose::Meta::Method::Accessor::Native::Reader;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native';
+
+sub _generate_method {
+    my $self = shift;
+
+    my $inv = '$self';
+
+    my $code = 'sub {';
+    $code .= "\n" . $self->_inline_pre_body(@_);
+
+    $code .= "\n" . 'my $self = shift;';
+    $code .= "\n" . $self->_inline_curried_arguments;
+    $code .= "\n" . $self->_inline_check_argument_count;
+    $code .= "\n" . $self->_inline_check_arguments;
+
+    $code .= "\n" . $self->_inline_check_lazy($inv);
+    $code .= "\n" . $self->_inline_post_body(@_);
+
+    my $slot_access = $self->_inline_get($inv);
+
+    $code .= "\n" . $self->_inline_return_value($slot_access);
+    $code .= "\n}";
+
+    return $code;
+}
+
+sub _inline_return_value {
+    my ( $self, $slot_access ) = @_;
+
+    'return ' . $self->_return_value($slot_access) . ';';
+}
+
+1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
new file mode 100644
index 0000000..60b672d
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
@@ -0,0 +1,94 @@
+package Moose::Meta::Method::Accessor::Native::Writer;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native';
+
+sub _generate_method {
+    my $self = shift;
+
+    my $inv = '$self';
+
+    my $slot_access = $self->_inline_get($inv);
+
+    my $code = 'sub {';
+    $code .= "\n" . $self->_inline_pre_body(@_);
+
+    $code .= "\n" . 'my $self = shift;';
+
+    $code .= "\n" . $self->_inline_check_lazy($inv);
+
+    $code .= "\n" . $self->_inline_curried_arguments;
+
+    $code .= "\n" . $self->_inline_check_argument_count;
+
+    $code .= "\n" . $self->_inline_process_arguments;
+
+    $code .= "\n" . $self->_inline_check_arguments;
+
+    my $new_value       = $self->_new_value($slot_access);
+    my $potential_value = $self->_potential_value($slot_access);
+
+    $code .= "\n" . $self->_inline_copy_value( \$potential_value );
+
+    $code .= "\n"
+        . $self->_inline_tc_code(
+        $new_value,
+        $potential_value
+        );
+
+    $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
+    $code .= "\n" . $self->_capture_old_value($slot_access);
+
+    $code .= "\n"
+        . $self->_inline_set_new_value(
+        $inv,
+        $potential_value
+        );
+
+    $code .= "\n" . $self->_inline_post_body(@_);
+    $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
+
+    $code .= "\n" . $self->_return_value( $inv, '@old' );
+
+    $code .= "\n}";
+
+    return $code;
+}
+
+sub _inline_process_arguments {q{}}
+
+sub _inline_check_arguments {q{}}
+
+sub _value_needs_copy {0}
+
+sub _inline_tc_code {die}
+
+sub _inline_check_coercion {die}
+
+sub _inline_check_constraint {
+    my $self = shift;
+
+    return q{} unless $self->_constraint_must_be_checked;
+
+    return $self->SUPER::_inline_check_constraint( $_[0] );
+}
+
+sub _constraint_must_be_checked {die}
+
+sub _capture_old_value { return q{} }
+
+sub _inline_set_new_value {
+    my $self = shift;
+
+    return $self->SUPER::_inline_store(@_);
+}
+
+sub _return_value      { return q{} }
+
+1;