close over the coercion sub separately

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 53504bd..e6d5172 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -551,12 +551,13 @@ sub set_value {
 
 sub _inline_set_value {
     my $self = shift;
-    my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_;
+    my ($instance, $value, $tc, $coercion, $tc_obj, $for_constructor) = @_;
 
-    my $old   = '@old';
-    my $copy  = '$val';
-    $tc     ||= '$type_constraint';
-    $tc_obj ||= '$type_constraint_obj';
+    my $old     = '@old';
+    my $copy    = '$val';
+    $tc       ||= '$type_constraint';
+    $coercion ||= '$type_coercion';
+    $tc_obj   ||= '$type_constraint_obj';
 
     my @code;
     if ($self->_writer_value_needs_copy) {
@@ -568,7 +569,7 @@ sub _inline_set_value {
     push @code, $self->_inline_check_required
         unless $for_constructor;
 
-    push @code, $self->_inline_tc_code($value, $tc, $tc_obj);
+    push @code, $self->_inline_tc_code($value, $tc, $coercion, $tc_obj);
 
     # constructors do triggers all at once at the end
     push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
@@ -617,19 +618,37 @@ sub _inline_check_required {
 
 sub _inline_tc_code {
     my $self = shift;
+    my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_;
     return (
-        $self->_inline_check_coercion(@_),
-        $self->_inline_check_constraint(@_),
+        $self->_inline_check_coercion(
+            $value, $tc, $coercion, $is_lazy,
+        ),
+        $self->_inline_check_constraint(
+            $value, $tc, $tc_obj, $is_lazy,
+        ),
     );
 }
 
 sub _inline_check_coercion {
     my $self = shift;
-    my ($value, $tc, $tc_obj) = @_;
+    my ($value, $tc, $coercion) = @_;
 
     return unless $self->should_coerce && $self->type_constraint->has_coercion;
 
-    return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
+    if ( $self->type_constraint->can_be_inlined ) {
+        return (
+            'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
+                $value . ' = ' . $coercion . '->(' . $value . ');',
+            '}',
+        );
+    }
+    else {
+        return (
+            'if (!' . $tc . '->(' . $value . ')) {',
+                $value . ' = ' . $coercion . '->(' . $value . ');',
+            '}',
+        );
+    }
 }
 
 sub _inline_check_constraint {
@@ -755,21 +774,22 @@ sub get_value {
 
 sub _inline_get_value {
     my $self = shift;
-    my ($instance, $tc, $tc_obj) = @_;
+    my ($instance, $tc, $coercion, $tc_obj) = @_;
 
     my $slot_access = $self->_inline_instance_get($instance);
     $tc           ||= '$type_constraint';
+    $coercion     ||= '$type_coercion';
     $tc_obj       ||= '$type_constraint_obj';
 
     return (
-        $self->_inline_check_lazy($instance, $tc, $tc_obj),
+        $self->_inline_check_lazy($instance, $tc, $coercion, $tc_obj),
         $self->_inline_return_auto_deref($slot_access),
     );
 }
 
 sub _inline_check_lazy {
     my $self = shift;
-    my ($instance, $tc, $tc_obj) = @_;
+    my ($instance, $tc, $coercion, $tc_obj) = @_;
 
     return unless $self->is_lazy;
 
@@ -777,14 +797,14 @@ sub _inline_check_lazy {
 
     return (
         'if (!' . $slot_exists . ') {',
-            $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'),
+            $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $tc_obj, 'lazy'),
         '}',
     );
 }
 
 sub _inline_init_from_default {
     my $self = shift;
-    my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_;
+    my ($instance, $default, $tc, $coercion, $tc_obj, $for_lazy) = @_;
 
     if (!($self->has_default || $self->has_builder)) {
         $self->throw_error(
@@ -801,7 +821,7 @@ sub _inline_init_from_default {
         # to do things like possibly only do member tc checks, which isn't
         # appropriate for checking the result of a default
         $self->has_type_constraint
-            ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $for_lazy),
+            ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
                $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
             : (),
         $self->_inline_init_slot($instance, $default),

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index a0e242a..3a2ebe2 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -381,6 +381,7 @@ sub _inline_init_attr_from_constructor {
         '$instance',
         '$params->{\'' . $attr->init_arg . '\'}',
         '$type_constraint_bodies[' . $idx . ']',
+        '$type_coercions[' . $idx . ']',
         '$type_constraints[' . $idx . ']',
         'for constructor',
     );
@@ -409,6 +410,7 @@ sub _inline_init_attr_from_default {
             '$instance',
             '$default',
             '$type_constraint_bodies[' . $idx . ']',
+            '$type_coercions[' . $idx . ']',
             '$type_constraints[' . $idx . ']',
             'for constructor',
         ),

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index 44b1242..8601487 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -47,11 +47,16 @@ sub _eval_environment {
     if ($attr->has_type_constraint) {
         my $tc_obj = $attr->type_constraint;
 
-        # is this going to be an issue? it's currently used for coercions
-        # and the tc message, is there a way to inline those too?
+        # is this going to be an issue? it's currently only used for the tc
+        # message. is there a way to inline that too?
         $env->{'$type_constraint_obj'} = \$tc_obj;
-        $env->{'$type_constraint'}     = \($tc_obj->_compiled_type_constraint)
-            unless $tc_obj->can_be_inlined;
+
+        $env->{'$type_constraint'} = \(
+            $tc_obj->_compiled_type_constraint
+        ) unless $tc_obj->can_be_inlined;
+        $env->{'$type_coercion'} = \(
+            $tc_obj->coercion->_compiled_type_coercion
+        ) if $tc_obj->has_coercion;
 
         $env = { %$env, %{ $tc_obj->inline_environment } };
     }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
index 0952cad..941e00c 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
@@ -35,7 +35,7 @@ sub _generate_method {
         'sub {',
             'my ' . $inv . ' = shift;',
             $self->_inline_curried_arguments,
-            $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
             # get
             'if (@_ == 1) {',
                 $self->_inline_check_var_is_valid_index('$_[0]'),

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
index d06ae03..8d63951 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
@@ -50,6 +50,7 @@ sub _writer_value_needs_copy {
 
 sub _inline_tc_code {
     my $self = shift;
+    my ($value, $tc, $coercion, $tc_obj, $is_lazy) = @_;
 
     return unless $self->_constraint_must_be_checked;
 
@@ -60,8 +61,8 @@ sub _inline_tc_code {
     }
     else {
         return (
-            $self->_inline_check_coercion(@_),
-            $self->_inline_check_constraint(@_),
+            $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
+            $self->_inline_check_constraint($value, $tc, $tc_obj, $is_lazy),
         );
     }
 }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
index 1b8eafd..3a5de7f 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm
@@ -38,7 +38,7 @@ sub _generate_method {
         'sub {',
             'my ' . $inv . ' = shift;',
             $self->_inline_curried_arguments,
-            $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+            $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
             # get
             'if (@_ == 1) {',
                 $self->_inline_check_var_is_valid_key('$_[0]'),

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
index 4084c92..9d08fb8 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
@@ -32,7 +32,7 @@ sub _inline_reader_core {
         $self->_inline_check_argument_count,
         $self->_inline_process_arguments($inv, $slot_access),
         $self->_inline_check_arguments,
-        $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
         $self->_inline_return_value($slot_access),
     );
 }

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
index 165c619..1ea3ced 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
@@ -38,7 +38,7 @@ sub _inline_writer_core {
         $self->_inline_check_argument_count,
         $self->_inline_process_arguments($inv, $slot_access),
         $self->_inline_check_arguments('for writer'),
-        $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+        $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
     );
 
     if ($self->_return_value($slot_access)) {
@@ -50,7 +50,7 @@ sub _inline_writer_core {
     push @code, (
         $self->_inline_coerce_new_values,
         $self->_inline_copy_native_value(\$potential),
-        $self->_inline_tc_code($potential, '$type_constraint', '$type_constraint_obj'),
+        $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_constraint_obj'),
         $self->_inline_get_old_value_for_trigger($inv, $old),
         $self->_inline_capture_return_value($slot_access),
         $self->_inline_set_new_value($inv, $potential, $slot_access),
@@ -109,7 +109,7 @@ sub _inline_copy_native_value {
 around _inline_tc_code => sub {
     my $orig = shift;
     my $self = shift;
-    my ($value, $tc, $tc_obj, $for_lazy) = @_;
+    my ($value, $tc, $coercion, $tc_obj, $for_lazy) = @_;
 
     return unless $for_lazy || $self->_constraint_must_be_checked;
 

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 693c822..6b1d7c2 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -74,11 +74,18 @@ sub _eval_environment {
         defined $_ ? $_->_compiled_type_constraint : undef;
     } @type_constraints;
 
+    my @type_coercions = map {
+        defined $_ && $_->has_coercion
+            ? $_->coercion->_compiled_type_coercion
+            : undef
+    } @type_constraints;
+
     return {
         '$meta'  => \$self,
         '$attrs' => \$attrs,
         '$defaults' => \$defaults,
         '@type_constraints' => \@type_constraints,
+        '@type_coercions' => \@type_coercions,
         '@type_constraint_bodies' => \@type_constraint_bodies,
         ( map { defined($_) ? %{ $_->inline_environment } : () }
               @type_constraints ),