X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FMethod%2FAccessor%2FNative%2FArray%2FWriter.pm;h=39fbe4a5fd531abffcf37bc6fddc961c89871422;hb=44babf1f66a06b9e1a70a0f04841439e4bc71a6a;hp=ab4c7f458f1405ae4f878c70d90edf384a583677;hpb=4780fef9a765531631f0227684d8fef871a7d46d;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
index ab4c7f4..39fbe4a 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
@@ -3,114 +3,27 @@ package Moose::Meta::Method::Accessor::Native::Array::Writer;
 use strict;
 use warnings;
 
+use Class::MOP::MiniTrait;
+
 our $VERSION = '1.13';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
-use base qw(
-    Moose::Meta::Method::Accessor::Native::Array
-    Moose::Meta::Method::Accessor::Native::Writer
-);
-
-sub _new_value {'@_'}
-
-sub _value_needs_copy {
-    my $self = shift;
-
-    return $self->_constraint_must_be_checked
-        && !$self->_check_new_members_only;
-}
-
-sub _inline_tc_code {
-    my ( $self, $new_value, $potential_value ) = @_;
-
-    return q{} unless $self->_constraint_must_be_checked;
-
-    if ( $self->_check_new_members_only ) {
-        return q{} unless $self->_adds_members;
-
-        return $self->_inline_check_member_constraint($new_value);
-    }
-    else {
-        return $self->_inline_check_coercion($potential_value) . "\n"
-            . $self->_inline_check_constraint($potential_value);
-    }
-}
-
-sub _check_new_members_only {
-    my $self = shift;
-
-    my $attr = $self->associated_attribute;
-
-    my $tc = $attr->type_constraint;
-
-    # If we have a coercion, we could come up with an entirely new value after
-    # coercing, so we need to check everything,
-    return 0 if $attr->should_coerce && $tc->has_coercion;
-
-    # If the parent is ArrayRef, that means we can just check the new members
-    # of the collection, because we know that we will always be generating an
-    # ArrayRef. However, if this type has its own constraint, we don't know
-    # what the constraint checks, so we need to check the whole value, not
-    # just the members.
-    return 1
-        if $tc->parent->name eq 'ArrayRef'
-            && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
-
-    return 0;
-}
-
-sub _inline_check_member_constraint {
-    my ( $self, $new_value ) = @_;
-
-    my $attr_name = $self->associated_attribute->name;
-
-    return '$member_tc->($_) || '
-        . $self->_inline_throw_error(
-        qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
-            . ' . $member_tc->get_message($_)',
-        "data => \$_"
-        ) . " for $new_value;";
-}
-
-sub _inline_check_constraint {
-    my $self = shift;
-
-    return q{} unless $self->_constraint_must_be_checked;
-
-    return $self->SUPER::_inline_check_constraint( $_[0] );
-}
+use base 'Moose::Meta::Method::Accessor::Native::Writer';
 
-sub _inline_get_old_value_for_trigger {
-    my ( $self, $instance ) = @_;
-
-    my $attr = $self->associated_attribute;
-    return '' unless $attr->has_trigger;
-
-    my $mi = $attr->associated_class->get_meta_instance;
-    my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
-
-    return
-          'my @old = '
-        . $pred . q{ ? } . '[ @{'
-        . $self->_inline_get($instance)
-        . '} ] : ()' . ";\n";
-}
-
-sub _eval_environment {
-    my $self = shift;
-
-    my $env = $self->SUPER::_eval_environment;
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+    'Moose::Meta::Method::Accessor::Native::Array'
+);
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+    'Moose::Meta::Method::Accessor::Native::Collection'
+);
 
-    return $env
-        unless $self->_constraint_must_be_checked
-            and $self->_check_new_members_only;
+sub _new_members {'@_'}
 
-    $env->{'$member_tc'}
-        = \( $self->associated_attribute->type_constraint->type_parameter
-            ->_compiled_type_constraint );
+sub _inline_copy_old_value {
+    my ( $self, $slot_access ) = @_;
 
-    return $env;
+    return '[ @{' . $slot_access . '} ]';
 }
 
 1;