Beginning of dzilization

[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor / Native / Collection.pm

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
index edf13c6..1924f76 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
@@ -3,38 +3,70 @@ package Moose::Meta::Method::Accessor::Native::Collection;
 use strict;
 use warnings;
 
-our $VERSION = '1.17';
-$VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Role;
 
 requires qw( _adds_members );
 
-around _value_needs_copy => sub {
-    shift;
+sub _inline_coerce_new_values {
+    my $self = shift;
+
+    return unless $self->associated_attribute->should_coerce;
+
+    return unless $self->_tc_member_type_can_coerce;
+
+    return (
+        '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
+                                             $self->_new_members . ';',
+    );
+}
+
+sub _tc_member_type_can_coerce {
+    my $self = shift;
+
+    my $member_tc = $self->_tc_member_type;
+
+    return $member_tc && $member_tc->has_coercion;
+}
+
+sub _tc_member_type {
+    my $self = shift;
+
+    my $tc = $self->associated_attribute->type_constraint;
+    while ($tc) {
+        return $tc->type_parameter
+            if $tc->can('type_parameter');
+        $tc = $tc->parent;
+    }
+
+    return;
+}
+
+sub _writer_value_needs_copy {
     my $self = shift;
 
     return $self->_constraint_must_be_checked
         && !$self->_check_new_members_only;
-};
+}
 
-around _inline_tc_code => sub {
-    shift;
-    my ( $self, $potential_value ) = @_;
+sub _inline_tc_code {
+    my $self = shift;
 
-    return q{} unless $self->_constraint_must_be_checked;
+    return unless $self->_constraint_must_be_checked;
 
-    if ( $self->_check_new_members_only ) {
-        return q{} unless $self->_adds_members;
+    if ($self->_check_new_members_only) {
+        return unless $self->_adds_members;
 
-        return $self->_inline_check_member_constraint( $self->_new_members );
+        return $self->_inline_check_member_constraint($self->_new_members);
     }
     else {
-        return $self->_inline_check_coercion($potential_value) . "\n"
-            . $self->_inline_check_constraint($potential_value);
+        return (
+            $self->_inline_check_coercion(@_),
+            $self->_inline_check_constraint(@_),
+        );
     }
-};
+}
 
 sub _check_new_members_only {
     my $self = shift;
@@ -62,40 +94,38 @@ sub _check_new_members_only {
 }
 
 sub _inline_check_member_constraint {
-    my ( $self, $new_value ) = @_;
+    my $self = shift;
+    my ($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;";
+    return (
+        'for (' . $new_value . ') {',
+            'if (!$member_tc->($_)) {',
+                $self->_inline_throw_error(
+                    '"A new member value for ' . $attr_name
+                  . ' does not pass its type constraint because: "'
+                  . ' . $member_tc_obj->get_message($_)',
+                    'data => $_',
+                ) . ';',
+            '}',
+        '}',
+    );
 }
 
-around _inline_check_constraint => sub {
-    my $orig = shift;
+sub _inline_get_old_value_for_trigger {
     my $self = shift;
-
-    return q{} unless $self->_constraint_must_be_checked;
-
-    return $self->$orig( $_[0] );
-};
-
-around _inline_get_old_value_for_trigger => sub {
-    shift;
-    my ( $self, $instance ) = @_;
+    my ($instance, $old) = @_;
 
     my $attr = $self->associated_attribute;
-    return '' unless $attr->has_trigger;
+    return unless $attr->has_trigger;
 
-    return
-          'my @old = '
-        . $self->_inline_has($instance) . q{ ? }
-        . $self->_inline_copy_old_value( $self->_inline_get($instance) )
-        . ": ();\n";
-};
+    return (
+        'my ' . $old . ' = ' . $self->_has_value($instance),
+            '? ' . $self->_copy_old_value($self->_get_value($instance)),
+            ': ();',
+    );
+}
 
 around _eval_environment => sub {
     my $orig = shift;
@@ -103,13 +133,13 @@ around _eval_environment => sub {
 
     my $env = $self->$orig(@_);
 
-    return $env
-        unless $self->_constraint_must_be_checked
-            && $self->_check_new_members_only;
+    my $member_tc = $self->_tc_member_type;
+
+    return $env unless $member_tc;
+
+    $env->{'$member_tc_obj'} = \($member_tc);
 
-    $env->{'$member_tc'}
-        = \( $self->associated_attribute->type_constraint->type_parameter
-            ->_compiled_type_constraint );
+    $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
 
     return $env;
 };